diff --git a/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.env b/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.env new file mode 100644 index 0000000..818c0e7 --- /dev/null +++ b/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.env @@ -0,0 +1,2 @@ +module purge +module load NEMO/prg-env diff --git a/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.fcm b/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.fcm new file mode 100644 index 0000000..474d336 --- /dev/null +++ b/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.fcm @@ -0,0 +1,20 @@ +%CCOMPILER mpiicc +%FCOMPILER mpiifort +%LINKER mpiifort -nofor-main + +%BASE_CFLAGS -fPIC -std=c++98 +%PROD_CFLAGS -O3 -D BOOST_DISABLE_ASSERTS +%DEV_CFLAGS -g +%DEBUG_CFLAGS -DBZ_DEBUG -g -fno-inline + +%BASE_FFLAGS -fPIC -D__NONE__ -132 +%PROD_FFLAGS -O3 +%DEV_FFLAGS -g -O2 -traceback +%DEBUG_FFLAGS -g -traceback + +%BASE_INC -D__NONE__ +%BASE_LD -lstdc++ + +%CPP mpiicc -EP +%FPP cpp -P +%MAKE gmake diff --git a/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.path b/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.path new file mode 100644 index 0000000..c1727b6 --- /dev/null +++ b/ARCH/ANEMONE/XIOS/arch-anemone-ifort-impi.path @@ -0,0 +1,9 @@ +NETCDF_INCDIR="-I$EBROOTNETCDF/include" +NETCDF_LIBDIR="-L$EBROOTNETCDF/lib" +NETCDF_LIB="-lnetcdff -lnetcdf" +MPI_INCDIR="" +MPI_LIBDIR="" +MPI_LIB="" +HDF5_INCDIR="" +HDF5_LIBDIR="" +HDF5_LIB="" diff --git a/ARCH/ANEMONE/arch-anemone-ifort-impi.fcm b/ARCH/ANEMONE/arch-anemone-ifort-impi.fcm new file mode 100644 index 0000000..c1efde4 --- /dev/null +++ b/ARCH/ANEMONE/arch-anemone-ifort-impi.fcm @@ -0,0 +1,56 @@ +# generic ifort compiler options for linux +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_xios is activated) +# XIOS_LIB xios library (taken into accound only if key_xios is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME $EBROOTNETCDF +%HDF5_HOME $EBROOTHDF5 +%XIOS_HOME XXX_XIOS_XXX + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 -lhdf5 +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ + +%CPP cpp +%FC mpiifort -c -fpp -fpp-name:/opt/software/rocky9/eb/software/GCCcore/12.3.0/bin/cpp -Wp,-P,-traditional +%FCFLAGS -i4 -r8 -O3 -fp-model precise -fno-alias +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS +%FPPFLAGS -P -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB + +%CC cc -Wl,--allow-multiple-definition +%CFLAGS -O0 diff --git a/ARCH/XIOS/arch-X86_ARCHER2-Cray.env b/ARCH/ARCHER2/XIOS/arch-X86_ARCHER2-Cray.env similarity index 100% rename from ARCH/XIOS/arch-X86_ARCHER2-Cray.env rename to ARCH/ARCHER2/XIOS/arch-X86_ARCHER2-Cray.env diff --git a/ARCH/XIOS/arch-X86_ARCHER2-Cray.fcm b/ARCH/ARCHER2/XIOS/arch-X86_ARCHER2-Cray.fcm similarity index 100% rename from ARCH/XIOS/arch-X86_ARCHER2-Cray.fcm rename to ARCH/ARCHER2/XIOS/arch-X86_ARCHER2-Cray.fcm diff --git a/ARCH/XIOS/arch-X86_ARCHER2-Cray.path b/ARCH/ARCHER2/XIOS/arch-X86_ARCHER2-Cray.path similarity index 100% rename from ARCH/XIOS/arch-X86_ARCHER2-Cray.path rename to ARCH/ARCHER2/XIOS/arch-X86_ARCHER2-Cray.path diff --git a/ARCH/arch-X86_ARCHER2-Cray.fcm b/ARCH/ARCHER2/arch-X86_ARCHER2-Cray.fcm similarity index 100% rename from ARCH/arch-X86_ARCHER2-Cray.fcm rename to ARCH/ARCHER2/arch-X86_ARCHER2-Cray.fcm diff --git a/ARCH/SINGULARITY/nemo/arch-singularity.fcm b/ARCH/SINGULARITY/nemo/arch-singularity.fcm new file mode 100644 index 0000000..36536fd --- /dev/null +++ b/ARCH/SINGULARITY/nemo/arch-singularity.fcm @@ -0,0 +1,56 @@ +# compiler options for Archer CRAY XC-30 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /opt/netcdf/install +%HDF5_HOME /opt/hdf5/install +%XIOS_HOME XXX_XIOS_DIR_XXX + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lcurl -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ -L/usr/lib/gcc/x86_64-linux-gnu/5 + +%CPP cpp -Dkey_nosignedzero -P -traditional +%FC mpif90 +%FCFLAGS -fdefault-double-8 -fdefault-real-8 -O1 -funroll-all-loops -fcray-pointer -ffree-line-length-none -w -fallow-argument-mismatch +%FFLAGS -fdefault-double-8 -fdefault-real-8 -O1 -funroll-all-loops -fcray-pointer -ffree-line-length-none -w -fallow-argument-mismatch +%LD /usr/bin/mpif90 +%FPPFLAGS -P -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB + +%CC mpicc +%CFLAGS -O0 diff --git a/ARCH/SINGULARITY/xios/arch-singularity.env b/ARCH/SINGULARITY/xios/arch-singularity.env new file mode 100644 index 0000000..282a6f3 --- /dev/null +++ b/ARCH/SINGULARITY/xios/arch-singularity.env @@ -0,0 +1,8 @@ +export HDF5_INC_DIR=/opt/hdf5/install/include +export HDF5_LIB_DIR=/opt/hdf5/install/lib + +export NETCDF_INC_DIR=/opt/netcdf/install/include +export NETCDF_LIB_DIR=/opt/netcdf/install/lib + +export BOOST_INC_DIR=$HOME/boost +export BOOST_LIB_DIR=$HOME/boost diff --git a/ARCH/SINGULARITY/xios/arch-singularity.fcm b/ARCH/SINGULARITY/xios/arch-singularity.fcm new file mode 100644 index 0000000..aab6b57 --- /dev/null +++ b/ARCH/SINGULARITY/xios/arch-singularity.fcm @@ -0,0 +1,20 @@ +%CCOMPILER mpicc +%FCOMPILER mpif90 +%LINKER mpif90 + +%BASE_CFLAGS -w -lcurl +%PROD_CFLAGS -O2 -D BOOST_DISABLE_ASSERTS -std=c++98 +%DEV_CFLAGS -g -O2 +%DEBUG_CFLAGS -g + +%BASE_FFLAGS -D__NONE__ +%PROD_FFLAGS -O2 +%DEV_FFLAGS -g -O2 +%DEBUG_FFLAGS -g + +%BASE_INC -D__NONE__ +%BASE_LD -lcurl -lstdc++ + +%CPP cpp +%FPP cpp -P +%MAKE gmake diff --git a/ARCH/SINGULARITY/xios/arch-singularity.path b/ARCH/SINGULARITY/xios/arch-singularity.path new file mode 100644 index 0000000..f8c89a4 --- /dev/null +++ b/ARCH/SINGULARITY/xios/arch-singularity.path @@ -0,0 +1,15 @@ +NETCDF_INCDIR="-I $NETCDF_INC_DIR" +NETCDF_LIBDIR="-L $NETCDF_LIB_DIR" +NETCDF_LIB="-lnetcdff -lnetcdf" + +MPI_INCDIR="" +MPI_LIBDIR="" +MPI_LIB="-lcurl" + +HDF5_INCDIR="-I $HDF5_INC_DIR" +HDF5_LIBDIR="-L $HDF5_LIB_DIR" +HDF5_LIB="-lhdf5_hl -lhdf5 -lhdf5 -lz" + +BOOST_INCDIR="-I $BOOST_INC_DIR" +BOOST_LIBDIR="-L $BOOST_LIB_DIR" +BOOST_LIB="" diff --git a/EXP_tideonly/context_nemo.xml b/EXP_tideonly/context_nemo.xml deleted file mode 100644 index cb2fc63..0000000 --- a/EXP_tideonly/context_nemo.xml +++ /dev/null @@ -1,120 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/EXP_tideonly/domain_def_nemo.xml b/EXP_tideonly/domain_def_nemo.xml deleted file mode 100755 index a8f71f8..0000000 --- a/EXP_tideonly/domain_def_nemo.xml +++ /dev/null @@ -1,258 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/EXP_tideonly/field_def_nemo-opa.xml b/EXP_tideonly/field_def_nemo-opa.xml deleted file mode 100755 index 2b8f9e0..0000000 --- a/EXP_tideonly/field_def_nemo-opa.xml +++ /dev/null @@ -1,1213 +0,0 @@ - - - - - - - - - - - - - - - - toce * e3t - - soce * e3t - - - - - - - sst * sst - - - - - - - - - - - - sss * sss - - - - - - - - - ssh * ssh - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - topthdep - pycndep - - - - - - - - - - sshdyn * sshdyn - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - uoce * e3u - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - voce * e3v - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) - sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) - - - - - - - - - - - - - ttrd_ldf + ttrd_zdf - ttrd_zdfp - strd_ldf + strd_zdf - strd_zdfp - - - - - - - - - - - - - - - - - - - - - ttrd_xad * e3t - strd_xad * e3t - ttrd_yad * e3t - strd_yad * e3t - ttrd_zad * e3t - strd_zad * e3t - ttrd_ad * e3t - strd_ad * e3t - ttrd_totad * e3t - strd_totad * e3t - ttrd_ldf * e3t - strd_ldf * e3t - ttrd_zdf * e3t - strd_zdf * e3t - ttrd_evd * e3t - strd_evd * e3t - - - ttrd_iso * e3t - strd_iso * e3t - ttrd_zdfp * e3t - strd_zdfp * e3t - - - ttrd_dmp * e3t - strd_dmp * e3t - ttrd_bbl * e3t - strd_bbl * e3t - ttrd_npc * e3t - strd_npc * e3t - ttrd_qns * e3t_surf - strd_cdt * e3t_surf - ttrd_qsr * e3t - ttrd_bbc * e3t - ttrd_atf * e3t - strd_atf * e3t - ttrd_tot * e3t - strd_tot * e3t - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/EXP_tideonly/namelist_cfg b/EXP_tideonly/namelist_cfg deleted file mode 100644 index a57b188..0000000 --- a/EXP_tideonly/namelist_cfg +++ /dev/null @@ -1,284 +0,0 @@ -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -!! NEMO/OPA Configuration namelist : used to overwrite defaults values defined in SHARED/namelist_ref -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! -!----------------------------------------------------------------------- -&namrun ! parameters of the run -!----------------------------------------------------------------------- - cn_exp = "AMM7_SURGE" ! experience name - nn_it000 = 7201 ! first time step - nn_itend = 77280 ! 365 days 8 per hour ! 70080 ! plus 30*4 days - nn_date0 = 20180601 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) - nn_time0 = 0 ! initial time of day in hhmm - nn_leapy = 1 ! Leap year calendar (1) or not (0) - ln_rstart = .false. ! start from rest (F) or from a restart file (T) - nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T - nn_rstctl = 2 ! restart control ==> activated only if ln_rstart=T - ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist - ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart - ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart - cn_ocerst_in = "AMM7_SURGE_00007200_restart" ! suffix of ocean restart name (input) - cn_ocerst_indir = "./Restart_files" ! directory from which to read input ocean restarts - cn_ocerst_out = "restart" ! suffix of ocean restart name (output) - cn_ocerst_outdir= "./Restart_files" ! directory in which to write output ocean restarts - nn_istate = 0 ! output the initial state (1) or not (0) - nn_stock = 70080 ! 30 days ! frequency of creation of a restart file (modulo referenced to 1) - nn_write = 70080 ! 30 days ! frequency of write in the output file (modulo referenced to nit000) -/ -!----------------------------------------------------------------------- -&namcfg ! parameters of the configuration -!----------------------------------------------------------------------- - ln_read_cfg = .true. ! (=T) read the domain configuration file - ! (=F) user defined configuration ==>>> see usrdef(_...) modules - cn_domcfg = "domain_cfg" ! domain configuration filename -/ -!----------------------------------------------------------------------- -&namdom ! space and time domain (bathymetry, mesh, timestep) -!----------------------------------------------------------------------- - ln_2d = .true. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) - rn_rdt = 450 ! time step for the dynamics (and tracer if nn_acc=0) -/ - -!----------------------------------------------------------------------- -&namtsd ! data : Temperature & Salinity -!----------------------------------------------------------------------- - ln_tsd_init = .false. ! Initialisation of ocean T & S with T &S input data (T) or not (F) - ln_tsd_tradmp = .false. ! damping of ocean T & S toward T &S input data (T) or not (F) -/ -!----------------------------------------------------------------------- -&namsbc ! Surface Boundary Condition (surface module) -!----------------------------------------------------------------------- - nn_fsbc = 1 ! frequency of surface boundary condition computation - ! (also = the frequency of sea-ice model call) - ln_usr = .true. - ln_blk = .false. - ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) - nn_ice = 0 ! =0 no ice boundary condition , - ln_rnf = .false. ! Runoffs (T => fill namsbc_rnf) - ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) - ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) - nn_fwb = 0 ! FreshWater Budget: =0 unchecked -/ -!----------------------------------------------------------------------- -&namsbc_usr ! namsbc_surge surge model fluxes -!----------------------------------------------------------------------- - ln_use_sbc = .false. ! (T) to turn on surge fluxes (wind and pressure only) - ! (F) for no fluxes (ie tide only case) - -! -! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! -! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! - sn_wndi = 'windspd_u_amm7' , 1 ,'x_wind', .true. , .false. , 'daily' ,'' , '' - sn_wndj = 'windspd_v_amm7' , 1 ,'y_wind', .true. , .false. , 'daily' ,'' , '' - cn_dir = './fluxes/' ! root directory for the location of the bulk files - rn_vfac = 1. ! multiplicative factor for ocean/ice velocity - ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) - rn_charn_const = 0.0275 -/ -!----------------------------------------------------------------------- -&namtra_qsr ! penetrative solar radiation -!----------------------------------------------------------------------- - ln_traqsr = .false. ! Light penetration (T) or not (F) - nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) -/ -!----------------------------------------------------------------------- -&namsbc_apr ! Atmospheric pressure used as ocean forcing or in bulk -!----------------------------------------------------------------------- -! ! 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_apr= 'pressure_amm7', 1 , 'air_pressure_at_sea_level' , .true. , .false., 'daily' , '' , '' , '' - cn_dir = './fluxes/'! root directory for the location of the bulk files - rn_pref = 101200. ! reference atmospheric pressure [N/m2]/ - ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) - ln_apr_obc = .true. ! inverse barometer added to OBC ssh data -/ -!----------------------------------------------------------------------- -&namlbc ! lateral momentum boundary condition -!----------------------------------------------------------------------- -! rn_shlat = 0 ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat - ! free slip ! partial slip ! no slip ! strong slip -/ - -!----------------------------------------------------------------------- -&nam_tide ! tide parameters -!----------------------------------------------------------------------- - ln_tide = .true. - ln_tide_ramp = .true. - rdttideramp = 1. - dn_love_number = 0.69 -! clname(1) = 'M2' ! name of constituent -! clname(2) = 'S2' -! clname(3) = 'K2' - clname(1) ='2N2' - clname(2)='EPS2' - clname(3)='J1' - clname(4)='K1' - clname(5)='K2' - clname(6)='L2' - clname(7)='LA2' - clname(8)='M2' - clname(9)='M3' - clname(10)='M4' - clname(11)='M6' - clname(12)='M8' - clname(13)='MF' - clname(14)='MKS2' - clname(15)='MM' - clname(16)='MN4' - clname(17)='MS4' - clname(18)='MSF' - clname(19)='MSQM' - clname(20)='MTM' - clname(21)='MU2' - clname(22)='N2' - clname(23)='N4' - clname(24)='NU2' - clname(25)='O1' - clname(26)='P1' - clname(27)='Q1' - clname(28)='R2' - clname(29)='S1' - clname(30)='S2' - clname(31)='S4' - clname(32)='SA' - clname(33)='SSA' - clname(34)='T2' -/ -!----------------------------------------------------------------------- -&nambdy ! unstructured open boundaries -!----------------------------------------------------------------------- - ln_bdy = .true. - nb_bdy = 1 ! number of open boundary sets - cn_coords_file = 'bdydta/coordinates.bdy.nc' ! bdy coordinates files - cn_dyn2d = 'flather' ! - nn_dyn2d_dta = 2 ! = 0, bdy data are equal to the initial state - ! = 1, bdy data are read in 'bdydata .nc' files - ! = 2, use tidal harmonic forcing data from files - ! = 3, use external data AND tidal harmonic forcing - cn_tra = 'frs' ! - nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state - ! = 1, bdy data are read in 'bdydata .nc' files - nn_rimwidth = 1 ! width of the relaxation zone -/ -!----------------------------------------------------------------------- -&nambdy_tide ! tidal forcing at open boundaries -!----------------------------------------------------------------------- - filtide = 'bdydta/AMM7_surge_bdytide_rotT_' ! file name root of tidal forcing files - ln_bdytide_2ddta = .false. -/ -!----------------------------------------------------------------------- -&nambfr ! bottom friction -!----------------------------------------------------------------------- - nn_bfr = 2 ! type of bottom friction : = 0 : free slip, = 1 : linear friction - ! = 2 : nonlinear friction - rn_bfri2 = 2.4e-3 ! bottom drag coefficient (non linear case) - rn_bfeb2 = 0.0e0 ! bottom turbulent kinetic energy background (m2/s2) - ln_loglayer = .false. ! loglayer bottom friction (only effect when nn_bfr = 2) - rn_bfrz0 = 0.003 ! bottom roughness (only effect when ln_loglayer = .true.) -/ -!----------------------------------------------------------------------- -&nambbc ! bottom temperature boundary condition -!----------------------------------------------------------------------- - ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom -/ -!----------------------------------------------------------------------- -&nambbl ! bottom boundary layer scheme -!----------------------------------------------------------------------- - nn_bbl_ldf = 0 ! diffusive bbl (=1) or not (=0) -/ -!----------------------------------------------------------------------- -&nameos ! ocean physical parameters -!----------------------------------------------------------------------- - ln_teos10 = .true. ! = Use TEOS-10 equation of state -/ -!----------------------------------------------------------------------- -&namdyn_vor ! option of physics/algorithm (not control by CPP keys) -!----------------------------------------------------------------------- - ln_dynvor_een = .true. ! energy & enstrophy scheme -/ -!----------------------------------------------------------------------- -&namdyn_hpg ! Hydrostatic pressure gradient option -!----------------------------------------------------------------------- - ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) - ln_hpg_sco = .true. ! s-coordinate (Standard Jacobian scheme) -/ -!----------------------------------------------------------------------- -&namdyn_spg ! surface pressure gradient (CPP key only) -!----------------------------------------------------------------------- - ln_dynspg_ts = .true. ! split-explicit free surface - ln_bt_auto = .true. ! Set nn_baro automatically to be just below - ! a user defined maximum courant number (rn_bt_cmax) -/ -!----------------------------------------------------------------------- -&namdyn_ldf ! lateral diffusion on momentum -!----------------------------------------------------------------------- - ! ! Type of the operator : - ln_dynldf_blp = .true. ! bilaplacian operator - ln_dynldf_lap = .false. ! bilaplacian operator - ! ! Direction of action : - ln_dynldf_lev = .true. ! iso-level - ! Coefficient - rn_ahm_0 = 60.0 ! horizontal laplacian eddy viscosity [m2/s] - rn_bhm_0 = -1.0e+9 ! horizontal bilaplacian eddy viscosity [m4/s] -/ -!----------------------------------------------------------------------- -&namzdf ! vertical physics -!----------------------------------------------------------------------- - rn_avm0 = 0.1e-6 ! vertical eddy viscosity [m2/s] (background Kz if not "key_zdfcst") - rn_avt0 = 0.1e-6 ! vertical eddy diffusivity [m2/s] (background Kz if not "key_zdfcst") - ln_zdfevd = .false. ! enhanced vertical diffusion (evd) (T) or not (F) - nn_evdm = 1 ! evd apply on tracer (=0) or on tracer and momentum (=1) -/ -!----------------------------------------------------------------------- -&nam_diaharm ! Harmonic analysis of tidal constituents ('key_diaharm') -!----------------------------------------------------------------------- - nit000_han = 1 ! First time step used for harmonic analysis - nitend_han = 7200 ! 30*4 days ! Last time step used for harmonic analysis - nstep_han = 20 ! 5 mins ! Time step frequency for harmonic analysis -! tname(1) = 'M2' ! Name of tidal constituents -! tname(2) = 'S2' -! tname(3) = 'K2' - tname(1)='K1' - tname(2)='K2' - tname(3)='M2' - tname(4)='M4' - tname(5)='N2' - tname(6)='O1' - tname(7)='P1' - tname(8)='Q1' - tname(9)='S2' -/ -!----------------------------------------------------------------------- -&nam_diaharm_fast ! Harmonic analysis of tidal constituents ("key_diaharm_fast") -!----------------------------------------------------------------------- - ln_diaharm_store = .true. - ln_diaharm_compute = .true. - ln_diaharm_read_restart = .false. - ln_ana_ssh = .true. - ln_ana_uvbar = .false. - ln_ana_bfric = .false. - ln_ana_rho = .false. - ln_ana_uv3d = .false. - ln_ana_w3d = .false. -! tname(1) = 'M2' -! tname(2) = 'S2' -! tname(3) = 'K2' - tname(1)='K1' - tname(2)='K2' - tname(3)='M2' - tname(4)='M4' - tname(5)='N2' - tname(6)='O1' - tname(7)='P1' - tname(8)='Q1' - tname(9)='S2' -/ -!----------------------------------------------------------------------- -&namwad ! Wetting and Drying namelist -!----------------------------------------------------------------------- - ln_wd = .false. !: key to turn on/off wetting/drying (T: on, F: off) - rn_wdmin1=0.1 !: minimum water depth on dried cells - rn_wdmin2 = 0.01 !: tolerrance of minimum water depth on dried cells - rn_wdld = 20.0 !: land elevation below which wetting/drying will be considered - nn_wdit = 10 !: maximum number of iteration for W/D limiter -/ diff --git a/EXP_tideonly/namelist_ref b/EXP_tideonly/namelist_ref deleted file mode 100644 index 150d4be..0000000 --- a/EXP_tideonly/namelist_ref +++ /dev/null @@ -1,1199 +0,0 @@ -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -!! namelist_ref -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -!! NEMO/OPA : 1 - run manager (namrun) -!! namelists 2 - Domain (namcfg, namzgr, namdom, namtsd, namcrs, namc1d, namc1d_uvd) -!! 3 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_sas) -!! namsbc_cpl, namtra_qsr, namsbc_rnf, -!! namsbc_apr, namsbc_ssr, namsbc_alb, namsbc_wave) -!! 4 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide) -!! 5 - bottom boundary (nambfr, nambbc, nambbl) -!! 6 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_ldfeiv, namtra_dmp) -!! 7 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) -!! 8 - Verical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_ddm, namzdf_tmx, namzdf_tmx_new) -!! 9 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb, namsto) -!! 10 - miscellaneous (nammpp, namctl) -!! 11 - Obs & Assim (namobs, nam_asminc) -!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - -!!====================================================================== -!! *** Run management namelists *** -!!====================================================================== -!! namrun parameters of the run -!!====================================================================== -! -!----------------------------------------------------------------------- -&namrun ! parameters of the run -!----------------------------------------------------------------------- - nn_no = 0 ! job number (no more used...) - cn_exp = "ORCA2" ! experience name - nn_it000 = 1 ! first time step - nn_itend = 5475 ! last time step (std 5475) - nn_date0 = 010101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) - nn_time0 = 0 ! initial time of day in hhmm - nn_leapy = 0 ! Leap year calendar (1) or not (0) - ln_rstart = .false. ! start from rest (F) or from a restart file (T) - nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T - nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T - ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist - ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart - ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart - cn_ocerst_in = "restart" ! suffix of ocean restart name (input) - cn_ocerst_indir = "." ! directory from which to read input ocean restarts - cn_ocerst_out = "restart" ! suffix of ocean restart name (output) - cn_ocerst_outdir= "." ! directory in which to write output ocean restarts - ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model - nn_istate = 0 ! output the initial state (1) or not (0) - ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) - nn_stock = 5475 ! frequency of creation of a restart file (modulo referenced to 1) - nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written - nn_write = 5475 ! frequency of write in the output file (modulo referenced to nn_it000) - ln_mskland = .false. ! mask land points in NetCDF outputs (costly: + ~15%) - ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard - ln_clobber = .true. ! clobber (overwrite) an existing file - nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) -/ -! -!!====================================================================== -!! *** Domain namelists *** -!!====================================================================== -!! namcfg parameters of the configuration -!! namdom space and time domain (bathymetry, mesh, timestep) -!! namwad Wetting and drying (default F) -!! namtsd data: temperature & salinity -!! namcrs coarsened grid (for outputs and/or TOP) ("key_crs") -!! namc1d 1D configuration options ("key_c1d") -!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") -!! namc1d_uvd 1D data (currents) ("key_c1d") -!!====================================================================== -! -!----------------------------------------------------------------------- -&namcfg ! parameters of the configuration -!----------------------------------------------------------------------- - ln_read_cfg = .false. ! (=T) read the domain configuration file - ! ! (=F) user defined configuration ==>>> see usrdef(_...) modules - cn_domcfg = "domain_cfg" ! domain configuration filename - ! - ln_write_cfg= .false. ! (=T) create the domain configuration file - cn_domcfg_out = "domain_cfg_out" ! newly created domain configuration filename - ! - ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present - ! ! in netcdf input files, as the start j-row for reading -/ -!----------------------------------------------------------------------- -&namdom ! space and time domain (bathymetry, mesh, timestep) -!----------------------------------------------------------------------- - ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time - nn_closea = 0 ! remove (=0) or keep (=1) closed seas and lakes (ORCA) - ! - nn_msh = 0 ! create (>0) a mesh file or not (=0) - rn_isfhmin = 1.00 ! treshold (m) to discriminate grounding ice to floating ice - ! - rn_rdt = 5760. ! time step for the dynamics (and tracer if nn_acc=0) - rn_atfp = 0.1 ! asselin time filter parameter - ! - ln_crs = .false. ! Logical switch for coarsening module - ln_2d = .false. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) -/ -!----------------------------------------------------------------------- -&namtsd ! data : Temperature & Salinity -!----------------------------------------------------------------------- -! ! 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_tem = 'data_1m_potential_temperature_nomask', -1 ,'votemper', .true. , .true. , 'yearly' , '' , '' , '' - sn_sal = 'data_1m_salinity_nomask' , -1 ,'vosaline', .true. , .true. , 'yearly' , '' , '' , '' - ! - cn_dir = './' ! root directory for the location of the runoff files - ln_tsd_init = .true. ! Initialisation of ocean T & S with T & S input data (T) or not (F) - ln_tsd_tradmp = .true. ! damping of ocean T & S toward T & S input data (T) or not (F) -/ -!----------------------------------------------------------------------- -&namwad ! Wetting and drying (default F) -!----------------------------------------------------------------------- - ln_wd = .false. ! T/F activation of wetting and drying - rn_wdmin1 = 0.1 ! Minimum wet depth on dried cells - rn_wdmin2 = 0.01 ! Tolerance of min wet depth on dried cells - rn_wdld = 20.0 ! Land elevation below which wetting/drying is allowed - nn_wdit = 10 ! Max iterations for W/D limiter -/ -!----------------------------------------------------------------------- -&namcrs ! coarsened grid (for outputs and/or TOP) ("key_crs") -!----------------------------------------------------------------------- - nn_factx = 3 ! Reduction factor of x-direction - nn_facty = 3 ! Reduction factor of y-direction - nn_binref = 0 ! Bin centering preference: NORTH or EQUAT - ! 0, coarse grid is binned with preferential treatment of the north fold - ! 1, coarse grid is binned with centering at the equator - ! Symmetry with nn_facty being odd-numbered. Asymmetry with even-numbered nn_facty. - nn_msh_crs = 1 ! create (=1) a mesh file or not (=0) - nn_crs_kz = 0 ! 0, MEAN of volume boxes - ! 1, MAX of boxes - ! 2, MIN of boxes - ln_crs_wn = .true. ! wn coarsened (T) or computed using horizontal divergence ( F ) -/ -!----------------------------------------------------------------------- -&namc1d ! 1D configuration options ("key_c1d") -!----------------------------------------------------------------------- - rn_lat1d = 50 ! Column latitude (default at PAPA station) - rn_lon1d = -145 ! Column longitude (default at PAPA station) - ln_c1d_locpt= .true. ! Localization of 1D config in a grid (T) or independant point (F) -/ -!----------------------------------------------------------------------- -&namc1d_dyndmp ! U & V newtonian damping ("key_c1d") -!----------------------------------------------------------------------- - ln_dyndmp = .false. ! add a damping term (T) or not (F) -/ -!----------------------------------------------------------------------- -&namc1d_uvd ! data: U & V currents ("key_c1d") -!----------------------------------------------------------------------- -! ! 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_ucur = 'ucurrent' , -1 ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' - sn_vcur = 'vcurrent' , -1 ,'v_current', .false. , .true. , 'monthly' , '' , 'Vme' , '' -! - cn_dir = './' ! root directory for the location of the files - ln_uvd_init = .false. ! Initialisation of ocean U & V with U & V input data (T) or not (F) - ln_uvd_dyndmp = .false. ! damping of ocean U & V toward U & V input data (T) or not (F) -/ - -!!====================================================================== -!! *** Surface Boundary Condition namelists *** -!!====================================================================== -!! namsbc surface boundary condition -!! 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 -!! namtra_qsr penetrative solar radiation (ln_traqsr =T) -!! namsbc_rnf river runoffs (ln_rnf =T) -!! namsbc_isf ice shelf melting/freezing (nn_isf >0) -!! namsbc_iscpl coupling option between land ice model and ocean -!! namsbc_apr Atmospheric Pressure (ln_apr_dyn =T) -!! namsbc_ssr sea surface restoring term (for T and/or S) (ln_ssr =T) -!! namsbc_alb albedo parameters -!! namsbc_wave external fields from wave model (ln_wave =T) -!! namberg iceberg floats (ln_icebergs=T) -!!====================================================================== -! -!----------------------------------------------------------------------- -&namsbc ! Surface Boundary Condition (surface module) -!----------------------------------------------------------------------- - nn_fsbc = 5 ! frequency of surface boundary condition computation - ! (also = the frequency of sea-ice & iceberg model call) - ! Type of air-sea fluxes - ln_usr = .false. ! user defined formulation (T => check usrdef_sbc) - ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) - ln_blk = .true. ! Bulk formulation (T => fill namsbc_blk ) - ! Type of coupling (Ocean/Ice/Atmosphere) : - ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) - ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) - nn_components = 0 ! configuration of the opa-sas OASIS coupling - ! =0 no opa-sas OASIS coupling: default single executable configuration - ! =1 opa-sas OASIS coupling: multi executable configuration, OPA component - ! =2 opa-sas OASIS coupling: multi executable configuration, SAS component - nn_limflx = -1 ! LIM3 Multi-category heat flux formulation (use -1 if LIM3 is not used) - ! =-1 Use per-category fluxes, bypass redistributor, forced mode only, not yet implemented coupled - ! = 0 Average per-category fluxes (forced and coupled mode) - ! = 1 Average and redistribute per-category fluxes, forced mode only, not yet implemented coupled - ! = 2 Redistribute a single flux over categories (coupled mode only) - ! Sea-ice : - nn_ice = 3 ! =0 no ice boundary condition , - ! =1 use observed ice-cover , - ! =2 to 4 : ice-model used (LIM2, LIM3 or CICE) ("key_lim3", "key_lim2", or "key_cice") - nn_ice_embd = 1 ! =0 levitating ice (no mass exchange, concentration/dilution effect) - ! =1 levitating ice with mass and salt exchange but no presure effect - ! =2 embedded sea-ice (full salt and mass exchanges and pressure) - ! Misc. options of sbc : - ln_traqsr = .true. ! Light penetration in the ocean (T => fill namtra_qsr) - ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave - ln_rnf = .true. ! runoffs (T => fill namsbc_rnf) - ln_ssr = .true. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) - nn_fwb = 2 ! FreshWater Budget: =0 unchecked - ! =1 global mean of e-p-r set to zero at each time step - ! =2 annual global mean of e-p-r set to zero - ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) - ln_isf = .false. ! ice shelf (T => fill namsbc_isf) - ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) - ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) - ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave) - ln_tauoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave) - ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) - nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , - ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) -/ -!----------------------------------------------------------------------- -&namsbc_flx ! surface boundary condition : flux formulation -!----------------------------------------------------------------------- -! ! 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_utau = 'utau' , 24 , 'utau' , .false. , .false., 'yearly' , '' , '' , '' - sn_vtau = 'vtau' , 24 , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' - sn_qtot = 'qtot' , 24 , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' - sn_qsr = 'qsr' , 24 , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' - sn_emp = 'emp' , 24 , 'emp' , .false. , .false., 'yearly' , '' , '' , '' - - cn_dir = './' ! root directory for the location of the flux files -/ -!----------------------------------------------------------------------- -&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk = T) -!----------------------------------------------------------------------- -! ! 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_wndi = 'u_10.15JUNE2009_fill' , 6 , 'U_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' - sn_wndj = 'v_10.15JUNE2009_fill' , 6 , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' - sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24 , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24 , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_tair = 't_10.15JUNE2009_fill' , 6 , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_humi = 'q_10.15JUNE2009_fill' , 6 , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_prec = 'ncar_precip.15JUNE2009_fill', -1 , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_snow = 'ncar_precip.15JUNE2009_fill', -1 , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_slp = 'slp.15JUNE2009_fill' , 6 , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - sn_tdif = 'taudif_core' , 24 , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' - ! ! bulk algorithm : - ln_NCAR = .false. ! "NCAR" algorithm (Large and Yeager 2008) - ln_COARE_3p0= .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) - ln_COARE_3p5= .false. ! "COARE 3.5" algorithm (Edson et al. 2013) - ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) - ! - cn_dir = './' ! root directory for the location of the bulk files - ln_taudif = .false. ! HF tau contribution: use "mean of stress module - module of the mean stress" data - rn_zqt = 10. ! Air temperature and humidity reference height (m) - rn_zu = 10. ! Wind vector reference height (m) - rn_pfac = 1. ! multiplicative factor for precipitation (total & snow) - rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.) - rn_vfac = 0. ! multiplicative factor for ocean/ice velocity - ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) - ln_Cd_L12 = .false. ! Modify the drag ice-atm and oce-atm depending on ice concentration - ! This parameterization is from Lupkes et al. (JGR 2012) -/ -!----------------------------------------------------------------------- -&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") -!----------------------------------------------------------------------- -! ! description ! multiple ! vector ! vector ! vector ! -! ! ! categories ! reference ! orientation ! grids ! -! send - sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , '' - sn_snd_alb = 'weighted ice' , 'no' , '' , '' , '' - sn_snd_thick = 'none' , 'no' , '' , '' , '' - sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' - sn_snd_co2 = 'coupled' , 'no' , '' , '' , '' - sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' - sn_snd_ifrac = 'none' , 'no' , '' , '' , '' - sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' -! receive - sn_rcv_w10m = 'none' , 'no' , '' , '' , '' - sn_rcv_taumod = 'coupled' , 'no' , '' , '' , '' - sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward', 'U,V' - sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , '' - sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , '' - sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , '' - sn_rcv_emp = 'conservative' , 'no' , '' , '' , '' - sn_rcv_rnf = 'coupled' , 'no' , '' , '' , '' - sn_rcv_cal = 'coupled' , 'no' , '' , '' , '' - sn_rcv_co2 = 'coupled' , 'no' , '' , '' , '' - sn_rcv_hsig = 'none' , 'no' , '' , '' , '' - sn_rcv_iceflx = 'none' , 'no' , '' , '' , '' - sn_rcv_mslp = 'none' , 'no' , '' , '' , '' - sn_rcv_phioc = 'none' , 'no' , '' , '' , '' - sn_rcv_sdrfx = 'none' , 'no' , '' , '' , '' - sn_rcv_sdrfy = 'none' , 'no' , '' , '' , '' - sn_rcv_wper = 'none' , 'no' , '' , '' , '' - sn_rcv_wnum = 'none' , 'no' , '' , '' , '' - sn_rcv_wstrf = 'none' , 'no' , '' , '' , '' - sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' -! - nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentialy sending/receiving data - ln_usecplmask = .false. ! 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) -/ -!----------------------------------------------------------------------- -&namsbc_sas ! Stand Alone Surface boundary condition -!----------------------------------------------------------------------- -! ! 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 ! - l_sasread = .TRUE. ! Read fields in a file if .TRUE. , or initialize to 0. in sbcssm.F90 if .FALSE. - sn_usp = 'sas_grid_U', 120 , 'vozocrtx', .true. , .true. , 'yearly' , '' , '' , '' - sn_vsp = 'sas_grid_V', 120 , 'vomecrty', .true. , .true. , 'yearly' , '' , '' , '' - sn_tem = 'sas_grid_T', 120 , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' - sn_sal = 'sas_grid_T', 120 , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' - sn_ssh = 'sas_grid_T', 120 , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' - sn_e3t = 'sas_grid_T', 120 , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' - sn_frq = 'sas_grid_T', 120 , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' - - ln_3d_uve = .true. ! specify whether we are supplying a 3D u,v and e3 field - ln_read_frq = .false. ! specify whether we must read frq or not - cn_dir = './' ! root directory for the location of the bulk files are -/ -!----------------------------------------------------------------------- -&namtra_qsr ! penetrative solar radiation (ln_traqsr=T) -!----------------------------------------------------------------------- -! ! 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_chl ='chlorophyll', -1 , 'CHLA' , .true. , .true. , 'yearly' , '' , '' , '' - - cn_dir = './' ! root directory for the location of the runoff files - ln_qsr_rgb = .true. ! RGB (Red-Green-Blue) light penetration - ln_qsr_2bd = .false. ! 2 bands light penetration - ln_qsr_bio = .false. ! bio-model light penetration - nn_chldta = 1 ! RGB : Chl data (=1) or cst value (=0) - rn_abs = 0.58 ! RGB & 2 bands: fraction of light (rn_si1) - rn_si0 = 0.35 ! RGB & 2 bands: shortess depth of extinction - rn_si1 = 23.0 ! 2 bands: longest depth of extinction - ln_qsr_ice = .true. ! light penetration for ice-model LIM3 -/ -!----------------------------------------------------------------------- -&namsbc_rnf ! runoffs namelist surface boundary condition (ln_rnf=T) -!----------------------------------------------------------------------- -! ! 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' , '' , '' , '' - - cn_dir = './' ! root directory for the location of the runoff files - 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 - ln_rnf_depth= .false. ! read in depth information for runoff - ln_rnf_tem = .false. ! read in temperature information for runoff - ln_rnf_sal = .false. ! read in salinity information for runoff - ln_rnf_depth_ini = .false. ! compute depth at initialisation from runoff file - rn_rnf_max = 5.735e-4 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) - rn_dep_max = 150. ! depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) - nn_rnf_depth_file = 0 ! create (=1) a runoff depth file or not (=0) -/ -!----------------------------------------------------------------------- -&namsbc_isf ! Top boundary layer (ISF) (nn_isf >0) -!----------------------------------------------------------------------- -! ! 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 ! -! nn_isf == 4 - sn_fwfisf = 'rnfisf' , -12 ,'sowflisf', .false. , .true. , 'yearly' , '' , '' , '' -! nn_isf == 3 - sn_rnfisf = 'rnfisf' , -12 ,'sofwfisf', .false. , .true. , 'yearly' , '' , '' , '' -! nn_isf == 2 and 3 - sn_depmax_isf='rnfisf' , -12 ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' - sn_depmin_isf='rnfisf' , -12 ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' -! nn_isf == 2 - sn_Leff_isf = 'rnfisf' , -12 ,'Leff' , .false. , .true. , 'yearly' , '' , '' , '' -! -! for all case - nn_isf = 1 ! ice shelf melting/freezing - ! 1 = presence of ISF 2 = bg03 parametrisation - ! 3 = rnf file for isf 4 = ISF fwf specified - ! option 1 and 4 need ln_isfcav = .true. (domzgr) -! only for nn_isf = 1 or 2 - rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula - rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula -! only for nn_isf = 1 or 4 - rn_hisf_tbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) - ! ! 0 => thickness of the tbl = thickness of the first wet cell -! only for nn_isf = 1 - nn_isfblk = 1 ! 1 ISOMIP like: 2 equations formulation (Hunter et al., 2006) - ! ! 2 ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) - nn_gammablk = 1 ! 0 = cst Gammat (= gammat/s) - ! ! 1 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) - ! ! 2 = velocity and stability dependent Gamma (Holland et al. 1999) -/ -!----------------------------------------------------------------------- -&namsbc_iscpl ! land ice / ocean coupling option -!----------------------------------------------------------------------- - nn_drown = 10 ! number of iteration of the extrapolation loop (fill the new wet cells) - ln_hsb = .false. ! activate conservation module (conservation exact after a time of rn_fiscpl) - nn_fiscpl = 43800 ! (number of time step) conservation period (maybe should be fix to the coupling frequencey of restart frequency) -/ -!----------------------------------------------------------------------- -&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) -!----------------------------------------------------------------------- -! ! 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_apr = 'patm' , -1 ,'somslpre', .true. , .true. , 'yearly' , '' , '' , '' - - cn_dir = './' ! root directory for the location of the bulk files - rn_pref = 101000. ! reference atmospheric pressure [N/m2]/ - ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) - ln_apr_obc = .false. ! inverse barometer added to OBC ssh data -/ -!----------------------------------------------------------------------- -&namsbc_ssr ! surface boundary condition : sea surface restoring (ln_ssr=T) -!----------------------------------------------------------------------- -! ! 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_sst = 'sst_data', 24 , 'sst' , .false. , .false., 'yearly' , '' , '' , '' - sn_sss = 'sss_data', -1 , 'sss' , .true. , .true. , 'yearly' , '' , '' , '' - - cn_dir = './' ! root directory for the location of the runoff files - nn_sstr = 0 ! add a retroaction term in the surface heat flux (=1) or not (=0) - nn_sssr = 2 ! add a damping term in the surface freshwater flux (=2) - ! or to SSS only (=1) or no damping term (=0) - rn_dqdt = -40. ! magnitude of the retroaction on temperature [W/m2/K] - 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_alb ! albedo parameters -!----------------------------------------------------------------------- - nn_ice_alb = 1 ! parameterization of ice/snow albedo - ! 0: Shine & Henderson-Sellers (JGR 1985), giving clear-sky albedo - ! 1: "home made" based on Brandt et al. (JClim 2005) and Grenfell & Perovich (JGR 2004), - ! giving cloud-sky albedo - rn_alb_sdry = 0.85 ! dry snow albedo : 0.80 (nn_ice_alb = 0); 0.85 (nn_ice_alb = 1); obs 0.85-0.87 (cloud-sky) - rn_alb_smlt = 0.75 ! melting snow albedo : 0.65 ( '' ) ; 0.75 ( '' ) ; obs 0.72-0.82 ( '' ) - rn_alb_idry = 0.60 ! dry ice albedo : 0.72 ( '' ) ; 0.60 ( '' ) ; obs 0.54-0.65 ( '' ) - rn_alb_imlt = 0.50 ! bare puddled ice albedo : 0.53 ( '' ) ; 0.50 ( '' ) ; obs 0.49-0.58 ( '' ) -/ -!----------------------------------------------------------------------- -&namsbc_wave ! External fields from wave model (ln_wave=T) -!----------------------------------------------------------------------- -! ! 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_cdg = 'sdw_wave' , 1 , 'drag_coeff' , .true. , .false. , 'daily' , '' , '' , '' - sn_usd = 'sdw_wave' , 1 , 'u_sd2d' , .true. , .false. , 'daily' , '' , '' , '' - sn_vsd = 'sdw_wave' , 1 , 'v_sd2d' , .true. , .false. , 'daily' , '' , '' , '' - sn_hsw = 'sdw_wave' , 1 , 'hs' , .true. , .false. , 'daily' , '' , '' , '' - sn_wmp = 'sdw_wave' , 1 , 'wmp' , .true. , .false. , 'daily' , '' , '' , '' - sn_wnum = 'sdw_wave' , 1 , 'wave_num' , .true. , .false. , 'daily' , '' , '' , '' - sn_tauoc = 'sdw_wave' , 1 , 'wave_stress', .true. , .false. , 'daily' , '' , '' , '' -! - cn_dir = './' ! root directory for the location of drag coefficient files -/ -!----------------------------------------------------------------------- -&namberg ! iceberg parameters (default: No iceberg) -!----------------------------------------------------------------------- - ln_icebergs = .false. ! iceberg floats or not - ln_bergdia = .true. ! Calculate budgets - nn_verbose_level = 1 ! Turn on more verbose output if level > 0 - nn_verbose_write = 15 ! Timesteps between verbose messages - nn_sample_rate = 1 ! Timesteps between sampling for trajectory storage - ! Initial mass required for an iceberg of each class - rn_initial_mass = 8.8e7, 4.1e8, 3.3e9, 1.8e10, 3.8e10, 7.5e10, 1.2e11, 2.2e11, 3.9e11, 7.4e11 - ! Proportion of calving mass to apportion to each class - rn_distribution = 0.24, 0.12, 0.15, 0.18, 0.12, 0.07, 0.03, 0.03, 0.03, 0.02 - ! Ratio between effective and real iceberg mass (non-dim) - ! i.e. number of icebergs represented at a point - rn_mass_scaling = 2000, 200, 50, 20, 10, 5, 2, 1, 1, 1 - ! thickness of newly calved bergs (m) - rn_initial_thickness = 40., 67., 133., 175., 250., 250., 250., 250., 250., 250. - rn_rho_bergs = 850. ! Density of icebergs - rn_LoW_ratio = 1.5 ! Initial ratio L/W for newly calved icebergs - ln_operator_splitting = .true. ! Use first order operator splitting for thermodynamics - rn_bits_erosion_fraction = 0. ! Fraction of erosion melt flux to divert to bergy bits - rn_sicn_shift = 0. ! Shift of sea-ice concn in erosion flux (0=1, 2nd order FCT scheme with vertical sub-timestepping - ! ! (number of sub-timestep = nn_fct_zts) - ln_traadv_mus = .false. ! MUSCL scheme - ln_mus_ups = .false. ! use upstream scheme near river mouths - ln_traadv_ubs = .false. ! UBS scheme - nn_ubs_v = 2 ! =2 , vertical 2nd order FCT / COMPACT 4th order - ln_traadv_qck = .false. ! QUICKEST scheme -/ -!----------------------------------------------------------------------- -&namtra_adv_mle ! mixed layer eddy parametrisation (Fox-Kemper param) (default: NO) -!----------------------------------------------------------------------- - ln_mle = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation - rn_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) - nn_mle = 1 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation - rn_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_mle=0) - rn_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) - rn_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) - nn_mld_uv = 0 ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) - nn_conv = 0 ! =1 no MLE in case of convection ; =0 always MLE - rn_rho_c_mle= 0.01 ! delta rho criterion used to calculate MLD for FK -/ -!----------------------------------------------------------------------- -&namtra_ldf ! lateral diffusion scheme for tracers (default: NO diffusion) -!----------------------------------------------------------------------- - ! ! Operator type: - ! ! no diffusion: set ln_traldf_lap=..._blp=F - ln_traldf_lap = .false. ! laplacian operator - ln_traldf_blp = .false. ! bilaplacian operator - ! - ! ! Direction of action: - ln_traldf_lev = .false. ! iso-level - ln_traldf_hor = .false. ! horizontal (geopotential) - ln_traldf_iso = .false. ! iso-neutral (standard operator) - ln_traldf_triad = .false. ! iso-neutral (triad operator) - ! - ! ! iso-neutral options: - ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators) - rn_slpmax = 0.01 ! slope limit (both operators) - ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only) - rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only) - ln_botmix_triad = .false. ! lateral mixing on bottom (triad only) - ! - ! ! Coefficients: - nn_aht_ijk_t = 0 ! space/time variation of eddy coef - ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file - ! ! = 0 constant - ! ! = 10 F(k) =ldf_c1d - ! ! = 20 F(i,j) =ldf_c2d - ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation - ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d - ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing) - rn_aht_0 = 2000. ! lateral eddy diffusivity (lap. operator) [m2/s] - rn_bht_0 = 1.e+12 ! lateral eddy diffusivity (bilap. operator) [m4/s] -/ -!----------------------------------------------------------------------- -&namtra_ldfeiv ! eddy induced velocity param. (default: NO) -!----------------------------------------------------------------------- - ln_ldfeiv =.false. ! use eddy induced velocity parameterization - ln_ldfeiv_dia =.false. ! diagnose eiv stream function and velocities - rn_aeiv_0 = 2000. ! eddy induced velocity coefficient [m2/s] - nn_aei_ijk_t = 21 ! space/time variation of the eiv coeficient - ! ! =-20 (=-30) read in eddy_induced_velocity_2D.nc (..._3D.nc) file - ! ! = 0 constant - ! ! = 10 F(k) =ldf_c1d - ! ! = 20 F(i,j) =ldf_c2d - ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation - ! ! = 30 F(i,j,k) =ldf_c2d + ldf_c1d -/ -!----------------------------------------------------------------------- -&namtra_dmp ! tracer: T & S newtonian damping (default: NO) -!----------------------------------------------------------------------- - ln_tradmp = .true. ! add a damping termn (T) or not (F) - nn_zdmp = 0 ! vertical shape =0 damping throughout the water column - ! =1 no damping in the mixing layer (kz criteria) - ! =2 no damping in the mixed layer (rho crieria) - cn_resto ='resto.nc' ! Name of file containing restoration coeff. field (use dmp_tools to create this) -/ - -!!====================================================================== -!! *** Dynamics namelists *** -!!====================================================================== -!! namdyn_adv formulation of the momentum advection -!! namdyn_vor advection scheme -!! namdyn_hpg hydrostatic pressure gradient -!! namdyn_spg surface pressure gradient -!! namdyn_ldf lateral diffusion scheme -!!====================================================================== -! -!----------------------------------------------------------------------- -&namdyn_adv ! formulation of the momentum advection (default: vector form) -!----------------------------------------------------------------------- - ln_dynadv_vec = .true. ! vector form (T) or flux form (F) - nn_dynkeg = 0 ! scheme for grad(KE): =0 C2 ; =1 Hollingsworth correction - ln_dynadv_cen2= .false. ! flux form - 2nd order centered scheme - ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme - ln_dynzad_zts = .false. ! Use (T) sub timestepping for vertical momentum advection -/ -!----------------------------------------------------------------------- -&nam_vvl ! vertical coordinate options (default: zstar) -!----------------------------------------------------------------------- - ln_vvl_zstar = .true. ! zstar vertical coordinate - ln_vvl_ztilde = .false. ! ztilde vertical coordinate: only high frequency variations - ln_vvl_layer = .false. ! full layer vertical coordinate - ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar - ln_vvl_zstar_at_eqtor = .false. ! ztilde near the equator - rn_ahe3 = 0.0e0 ! thickness diffusion coefficient - rn_rst_e3t = 30.e0 ! ztilde to zstar restoration timescale [days] - rn_lf_cutoff = 5.0e0 ! cutoff frequency for low-pass filter [days] - rn_zdef_max = 0.9e0 ! maximum fractional e3t deformation - ln_vvl_dbg = .true. ! debug prints (T/F) -/ -!----------------------------------------------------------------------- -&namdyn_vor ! Vorticity / Coriolis scheme (default: NO) -!----------------------------------------------------------------------- - ln_dynvor_ene = .false. ! enstrophy conserving scheme - ln_dynvor_ens = .false. ! energy conserving scheme - ln_dynvor_mix = .false. ! mixed scheme - ln_dynvor_een = .false. ! energy & enstrophy scheme - nn_een_e3f = 1 ! e3f = masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) - ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) or not (=F) (all vorticity schemes) ! PLEASE DO NOT ACTIVATE -/ -!----------------------------------------------------------------------- -&namdyn_hpg ! Hydrostatic pressure gradient option (default: zps) -!----------------------------------------------------------------------- - ln_hpg_zco = .false. ! z-coordinate - full steps - ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) - ln_hpg_sco = .false. ! s-coordinate (standard jacobian formulation) - ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf - ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) - ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) -/ -!----------------------------------------------------------------------- -&namdyn_spg ! surface pressure gradient (default: NO) -!----------------------------------------------------------------------- - ln_dynspg_exp = .false. ! explicit free surface - ln_dynspg_ts = .false. ! split-explicit free surface - ln_bt_fw = .true. ! Forward integration of barotropic Eqs. - ln_bt_av = .true. ! Time filtering of barotropic variables - nn_bt_flt = 1 ! Time filter choice = 0 None - ! ! = 1 Boxcar over nn_baro sub-steps - ! ! = 2 Boxcar over 2*nn_baro " " - ln_bt_auto = .true. ! Number of sub-step defined from: - rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed - nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds -/ -!----------------------------------------------------------------------- -&namdyn_ldf ! lateral diffusion on momentum (default: NO) -!----------------------------------------------------------------------- - ! ! Type of the operator : - ! ! no diffusion: set ln_dynldf_lap=..._blp=F - ln_dynldf_lap = .false. ! laplacian operator - ln_dynldf_blp = .false. ! bilaplacian operator - ! ! Direction of action : - ln_dynldf_lev = .false. ! iso-level - ln_dynldf_hor = .false. ! horizontal (geopotential) - ln_dynldf_iso = .false. ! iso-neutral - ! ! Coefficient - nn_ahm_ijk_t = 0 ! space/time variation of eddy coef - ! ! =-30 read in eddy_viscosity_3D.nc file - ! ! =-20 read in eddy_viscosity_2D.nc file - ! ! = 0 constant - ! ! = 10 F(k)=c1d - ! ! = 20 F(i,j)=F(grid spacing)=c2d - ! ! = 30 F(i,j,k)=c2d*c1d - ! ! = 31 F(i,j,k)=F(grid spacing and local velocity) - ! ! = 32 F(i,j,k)=F(local gridscale and deformation rate) - ! Caution in 20 and 30 cases the coefficient have to be given for a 1 degree grid (~111km) - rn_ahm_0 = 40000. ! horizontal laplacian eddy viscosity [m2/s] - rn_ahm_b = 0. ! background eddy viscosity for ldf_iso [m2/s] - rn_bhm_0 = 1.e+12 ! horizontal bilaplacian eddy viscosity [m4/s] - ! ! Smagorinsky settings (nn_ahm_ijk_t = 32) : - rn_csmc = 3.5 ! Smagorinsky constant of proportionality - rn_minfac = 1.0 ! multiplier of theorectical lower limit - rn_maxfac = 1.0 ! multiplier of theorectical upper limit -/ - -!!====================================================================== -!! Tracers & Dynamics vertical physics namelists -!!====================================================================== -!! namzdf vertical physics -!! namzdf_ric richardson number dependent vertical mixing ("key_zdfric") -!! namzdf_tke TKE dependent vertical mixing ("key_zdftke") -!! namzdf_gls GLS vertical mixing ("key_zdfgls") -!! namzdf_ddm double diffusive mixing parameterization ("key_zdfddm") -!! namzdf_tmx tidal mixing parameterization ("key_zdftmx") -!!====================================================================== -! -!----------------------------------------------------------------------- -&namzdf ! vertical physics -!----------------------------------------------------------------------- - rn_avm0 = 1.2e-4 ! vertical eddy viscosity [m2/s] (background Kz if not "key_zdfcst") - rn_avt0 = 1.2e-5 ! vertical eddy diffusivity [m2/s] (background Kz if not "key_zdfcst") - nn_avb = 0 ! profile for background avt & avm (=1) or not (=0) - nn_havtb = 0 ! horizontal shape for avtb (=1) or not (=0) - ln_zdfevd = .true. ! enhanced vertical diffusion (evd) (T) or not (F) - nn_evdm = 0 ! evd apply on tracer (=0) or on tracer and momentum (=1) - rn_avevd = 100. ! evd mixing coefficient [m2/s] - ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm (T) or not (F) - nn_npc = 1 ! frequency of application of npc - nn_npcp = 365 ! npc control print frequency - ln_zdfexp = .false. ! time-stepping: split-explicit (T) or implicit (F) time stepping - nn_zdfexp = 3 ! number of sub-timestep for ln_zdfexp=T - ln_zdfqiao = .false. ! Enhanced wave vertical mixing Qiao (2010) (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) -/ -!----------------------------------------------------------------------- -&namzdf_ric ! richardson number dependent vertical diffusion ("key_zdfric" ) -!----------------------------------------------------------------------- - rn_avmri = 100.e-4 ! maximum value of the vertical viscosity - rn_alp = 5. ! coefficient of the parameterization - nn_ric = 2 ! coefficient of the parameterization - rn_ekmfc = 0.7 ! Factor in the Ekman depth Equation - rn_mldmin = 1.0 ! minimum allowable mixed-layer depth estimate (m) - rn_mldmax = 1000.0 ! maximum allowable mixed-layer depth estimate (m) - rn_wtmix = 10.0 ! vertical eddy viscosity coeff [m2/s] in the mixed-layer - rn_wvmix = 10.0 ! vertical eddy diffusion coeff [m2/s] in the mixed-layer - ln_mldw = .true. ! Flag to use or not the mixed layer depth param. -/ -!----------------------------------------------------------------------- -&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion ("key_zdftke") -!----------------------------------------------------------------------- - rn_ediff = 0.1 ! coef. for vertical eddy coef. (avt=rn_ediff*mxl*sqrt(e) ) - rn_ediss = 0.7 ! coef. of the Kolmogoroff dissipation - rn_ebb = 67.83 ! coef. of the surface input of tke (=67.83 suggested when ln_mxl0=T) - rn_emin = 1.e-6 ! minimum value of tke [m2/s2] - rn_emin0 = 1.e-4 ! surface minimum value of tke [m2/s2] - rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it) - nn_mxl = 2 ! 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 disspipative an mixing length scale - nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm) - ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) - rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value - ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002) - rn_lc = 0.15 ! coef. associated to Langmuir cells - nn_etau = 1 ! penetration of tke below the mixed layer (ML) due to near intertial waves - ! = 0 no penetration - ! = 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) - rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) - nn_htau = 1 ! type of exponential decrease of tke penetration below the ML - ! = 0 constant 10 m length scale - ! = 1 0.5m at the equator to 30m poleward of 40 degrees -/ -!----------------------------------------------------------------------- -&namzdf_gls ! GLS vertical diffusion ("key_zdfgls") -!----------------------------------------------------------------------- - rn_emin = 1.e-7 ! minimum value of e [m2/s2] - rn_epsmin = 1.e-12 ! minimum value of eps [m2/s3] - ln_length_lim = .true. ! limit on the dissipation rate under stable stratification (Galperin et al., 1988) - rn_clim_galp = 0.267 ! galperin limit - ln_sigpsi = .true. ! Activate or not Burchard 2001 mods on psi schmidt number in the wb case - rn_crban = 100. ! Craig and Banner 1994 constant for wb tke flux - rn_charn = 70000. ! Charnock constant for wb induced roughness length - rn_hsro = 0.02 ! Minimum surface roughness - rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met=2) - nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) - ! ! =3 requires ln_wave=T - nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum) - nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum) - nn_stab_func = 2 ! stability function (0=Galp, 1= KC94, 2=CanutoA, 3=CanutoB) - nn_clos = 1 ! predefined closure type (0=MY82, 1=k-eps, 2=k-w, 3=Gen) -/ -!----------------------------------------------------------------------- -&namzdf_ddm ! double diffusive mixing parameterization ("key_zdfddm") -!----------------------------------------------------------------------- - rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) - rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio -/ -!----------------------------------------------------------------------- -&namzdf_tmx ! tidal mixing parameterization ("key_zdftmx") -!----------------------------------------------------------------------- - rn_htmx = 500. ! vertical decay scale for turbulence (meters) - rn_n2min = 1.e-8 ! threshold of the Brunt-Vaisala frequency (s-1) - rn_tfe = 0.333 ! tidal dissipation efficiency - rn_me = 0.2 ! mixing efficiency - ln_tmx_itf = .true. ! ITF specific parameterisation - rn_tfe_itf = 1. ! ITF tidal dissipation efficiency -/ -!----------------------------------------------------------------------- -&namzdf_tmx_new ! internal wave-driven mixing parameterization ("key_zdftmx_new" & "key_zdfddm") -!----------------------------------------------------------------------- - nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) - ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency - ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) -/ -!!====================================================================== -!! *** Miscellaneous namelists *** -!!====================================================================== -!! nammpp Massively Parallel Processing ("key_mpp_mpi) -!! namctl Control prints -!! namsto Stochastic parametrization of EOS -!!====================================================================== -! -!----------------------------------------------------------------------- -&nammpp ! Massively Parallel Processing ("key_mpp_mpi) -!----------------------------------------------------------------------- - cn_mpi_send = 'I' ! mpi send/recieve type ='S', 'B', or 'I' for standard send, - ! buffer blocking send or immediate non-blocking sends, resp. - nn_buffer = 0 ! size in bytes of exported buffer ('B' case), 0 no exportation - ln_nnogather= .false. ! activate code to avoid mpi_allgather use at the northfold - jpni = 0 ! jpni number of processors following i (set automatically if < 1) - jpnj = 0 ! jpnj number of processors following j (set automatically if < 1) - jpnij = 0 ! jpnij number of local domains (set automatically if < 1) -/ -!----------------------------------------------------------------------- -&namctl ! Control prints -!----------------------------------------------------------------------- - ln_ctl = .false. ! trends control print (expensive!) - nn_print = 0 ! level of print (0 no extra print) - nn_ictls = 0 ! start i indice of control sum (use to compare mono versus - nn_ictle = 0 ! end i indice of control sum multi processor runs - nn_jctls = 0 ! start j indice of control over a subdomain) - nn_jctle = 0 ! end j indice of control - nn_isplt = 1 ! number of processors in i-direction - nn_jsplt = 1 ! number of processors in j-direction - nn_timing = 0 ! timing by routine activated (=1) creates timing.output file, or not (=0) - nn_diacfl = 0 ! Write out CFL diagnostics (=1) in cfl_diagnostics.ascii, or not (=0) -/ -!----------------------------------------------------------------------- -&namsto ! Stochastic parametrization of EOS (default: NO) -!----------------------------------------------------------------------- - ln_sto_eos = .false. ! stochastic equation of state - nn_sto_eos = 1 ! number of independent random walks - rn_eos_stdxy= 1.4 ! random walk horz. standard deviation (in grid points) - rn_eos_stdz = 0.7 ! random walk vert. standard deviation (in grid points) - rn_eos_tcor = 1440. ! random walk time correlation (in timesteps) - nn_eos_ord = 1 ! order of autoregressive processes - nn_eos_flt = 0 ! passes of Laplacian filter - rn_eos_lim = 2.0 ! limitation factor (default = 3.0) - ln_rststo = .false. ! start from mean parameter (F) or from restart file (T) - ln_rstseed = .true. ! read seed of RNG from restart file - cn_storst_in = "restart_sto" ! suffix of stochastic parameter restart file (input) - cn_storst_out = "restart_sto" ! suffix of stochastic parameter restart file (output) -/ - -!!====================================================================== -!! *** Diagnostics namelists *** -!!====================================================================== -!! namtrd dynamics and/or tracer trends (default F) -!! namptr Poleward Transport Diagnostics (default F) -!! namhsb Heat and salt budgets (default F) -!! namdiu Cool skin and warm layer models (default F) -!! namdiu Cool skin and warm layer models (default F) -!! namflo float parameters ("key_float") -!! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") -!! namdct transports through some sections ("key_diadct") -!! nam_diatmb Top Middle Bottom Output (default F) -!! nam_dia25h 25h Mean Output (default F) -!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") -!!====================================================================== -! -!----------------------------------------------------------------------- -&namtrd ! trend diagnostics (default F) -!----------------------------------------------------------------------- - ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE - ln_dyn_trd = .false. ! (T) 3D momentum trend output - ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet) - ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet) - ln_KE_trd = .false. ! (T) 3D Kinetic Energy trends - ln_PE_trd = .false. ! (T) 3D Potential Energy trends - ln_tra_trd = .false. ! (T) 3D tracer trend output - ln_tra_mxl = .false. ! (T) 2D tracer trends averaged over the mixed layer (not coded yet) - nn_trd = 365 ! print frequency (ln_glo_trd=T) (unit=time step) -/ -!!gm nn_ctls = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) -!!gm cn_trdrst_in = "restart_mld" ! suffix of ocean restart name (input) -!!gm cn_trdrst_out = "restart_mld" ! suffix of ocean restart name (output) -!!gm ln_trdmld_restart = .false. ! restart for ML diagnostics -!!gm ln_trdmld_instant = .false. ! flag to diagnose trends of instantantaneous or mean ML T/S -!!gm -!----------------------------------------------------------------------- -&namptr ! Poleward Transport Diagnostic (default F) -!----------------------------------------------------------------------- - ln_diaptr = .false. ! Poleward heat and salt transport (T) or not (F) - ln_subbas = .false. ! Atlantic/Pacific/Indian basins computation (T) or not -/ -!----------------------------------------------------------------------- -&namhsb ! Heat and salt budgets (default F) -!----------------------------------------------------------------------- - ln_diahsb = .false. ! check the heat and salt budgets (T) or not (F) -/ -!----------------------------------------------------------------------- -&namdiu ! Cool skin and warm layer models (default F) -!----------------------------------------------------------------------- - ln_diurnal = .false. ! - ln_diurnal_only = .false. ! -/ -!----------------------------------------------------------------------- -&namflo ! float parameters ("key_float") -!----------------------------------------------------------------------- - jpnfl = 1 ! total number of floats during the run - jpnnewflo = 0 ! number of floats for the restart - ln_rstflo = .false. ! float restart (T) or not (F) - nn_writefl = 75 ! frequency of writing in float output file - nn_stockfl = 5475 ! frequency of creation of the float restart file - ln_argo = .false. ! Argo type floats (stay at the surface each 10 days) - ln_flork4 = .false. ! trajectories computed with a 4th order Runge-Kutta (T) - ! ! or computed with Blanke' scheme (F) - ln_ariane = .true. ! Input with Ariane tool convention(T) - ln_flo_ascii= .true. ! Output with Ariane tool netcdf convention(F) or ascii file (T) -/ -!----------------------------------------------------------------------- -&nam_diaharm ! Harmonic analysis of tidal constituents ("key_diaharm") -!----------------------------------------------------------------------- - nit000_han = 1 ! First time step used for harmonic analysis - nitend_han = 75 ! Last time step used for harmonic analysis - nstep_han = 15 ! Time step frequency for harmonic analysis - tname(1) = 'M2' ! Name of tidal constituents - tname(2) = 'K1' -/ -!----------------------------------------------------------------------- -&namdct ! transports through some sections ("key_diadct") -!----------------------------------------------------------------------- - nn_dct = 15 ! time step frequency for transports computing - nn_dctwri = 15 ! time step frequency for transports writing - nn_secdebug= 112 ! 0 : no section to debug - ! ! -1 : debug all section - ! ! 0 < n : debug section number n -/ -!----------------------------------------------------------------------- -&nam_diatmb ! Top Middle Bottom Output (default F) -!----------------------------------------------------------------------- - ln_diatmb = .false. ! Choose Top Middle and Bottom output or not -/ -!----------------------------------------------------------------------- -&nam_dia25h ! 25h Mean Output (default F) -!----------------------------------------------------------------------- - ln_dia25h = .false. ! Choose 25h mean output or not -/ -!----------------------------------------------------------------------- -&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") -!----------------------------------------------------------------------- - nn_nchunks_i= 4 ! number of chunks in i-dimension - nn_nchunks_j= 4 ! number of chunks in j-dimension - nn_nchunks_k= 31 ! number of chunks in k-dimension - ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which - ! ! is optimal for postprocessing which works exclusively with horizontal slabs - ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression - ! ! (F) ignore chunking information and produce netcdf3-compatible files -/ - -!!====================================================================== -!! *** Observation & Assimilation *** -!!====================================================================== -!! namobs observation and model comparison -!! nam_asminc assimilation increments ('key_asminc') -!!====================================================================== -! -!----------------------------------------------------------------------- -&namobs ! observation usage switch -!----------------------------------------------------------------------- - ln_diaobs = .false. ! Logical switch for the observation operator - ln_t3d = .false. ! Logical switch for T profile observations - ln_s3d = .false. ! Logical switch for S profile observations - ln_sla = .false. ! Logical switch for SLA observations - ln_sst = .false. ! Logical switch for SST observations - ln_sic = .false. ! Logical switch for Sea Ice observations - ln_vel3d = .false. ! Logical switch for velocity observations - ln_altbias = .false. ! Logical switch for altimeter bias correction - ln_nea = .false. ! Logical switch for rejection of observations near land - ln_grid_global = .true. ! Logical switch for global distribution of observations - ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table - ln_ignmis = .true. ! Logical switch for ignoring missing files - ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there - ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs -! All of the *files* variables below are arrays. Use namelist_cfg to add more files - cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names - cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names - cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names - cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names - cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names - cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name - cn_gridsearchfile='gridsearch.nc' ! Grid search file name - rn_gridsearchres = 0.5 ! Grid search resolution - rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS - rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS - nn_1dint = 0 ! Type of vertical interpolation method - nn_2dint = 0 ! Type of horizontal interpolation method - nn_msshc = 0 ! MSSH correction scheme - rn_mdtcorr = 1.61 ! MDT correction - rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction - nn_profdavtypes = -1 ! Profile daily average types - array - ln_sstbias = .false. ! - cn_sstbias_files = 'sstbias.nc' ! -/ -!----------------------------------------------------------------------- -&nam_asminc ! assimilation increments ('key_asminc') -!----------------------------------------------------------------------- - ln_bkgwri = .false. ! Logical switch for writing out background state - ln_trainc = .false. ! Logical switch for applying tracer increments - ln_dyninc = .false. ! Logical switch for applying velocity increments - ln_sshinc = .false. ! Logical switch for applying SSH increments - ln_asmdin = .false. ! Logical switch for Direct Initialization (DI) - ln_asmiau = .false. ! Logical switch for Incremental Analysis Updating (IAU) - nitbkg = 0 ! Timestep of background in [0,nitend-nit000-1] - nitdin = 0 ! Timestep of background for DI in [0,nitend-nit000-1] - nitiaustr = 1 ! Timestep of start of IAU interval in [0,nitend-nit000-1] - nitiaufin = 15 ! Timestep of end of IAU interval in [0,nitend-nit000-1] - niaufn = 0 ! Type of IAU weighting function - ln_salfix = .false. ! Logical switch for ensuring that the sa > salfixmin - salfixmin = -9999 ! Minimum salinity after applying the increments - nn_divdmp = 0 ! Number of iterations of divergence damping operator -/ diff --git a/EXP_tideonly/runscript.slurm b/EXP_tideonly/runscript.slurm deleted file mode 100644 index 288e796..0000000 --- a/EXP_tideonly/runscript.slurm +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/bash -#SBATCH --job-name=amm7-surge -#SBATCH --time=00:05:00 -#SBATCH --account=n01-CLASS -#SBATCH --partition=standard -#SBATCH --qos=standard - -#SBATCH --nodes=1 -#SBATCH --ntasks-per-core=1 - -# load modules -#. /work/n01/n01/jdha/modules/gnu-mpich -. /work/n01/n01/annkat/SE-NEMO_UPD/SE-NEMO/scripts/env/gnu-mpich - -export OMP_NUM_THREADS=1 -echo `date` : Launch Job - -SRUN_CMD=`./slurm_setup -S 1 -s 1 -m 1 -C 95 -g 999 -N 128 -t 00:05:00 -a n01-CLASS -j amm7-surge` - -chmod u+x ./myscript_wrapper.sh - -echo $SRUN_CMD -eval $SRUN_CMD diff --git a/EXP_tideonly/slurm_setup b/EXP_tideonly/slurm_setup deleted file mode 100755 index a64b9cc..0000000 --- a/EXP_tideonly/slurm_setup +++ /dev/null @@ -1,261 +0,0 @@ -#!/usr/bin/env python3 -""" -Python version of mkslurm_alt by Andrew Coward using HetJobs. -""" -import argparse -import logging -import sys -from textwrap import dedent - - -def main(args): - """Create slurm scripts - - Args: - args: Parsed arguments. - """ - - # Verbosity - if args.v: - logging.basicConfig(level=logging.DEBUG) - else: - logging.basicConfig(level=logging.INFO) - cmd = f"{parser.prog} " + " ".join( - [ - f"{'-' if len(arg)==1 else '--'}{arg.replace('_', '-')} {val}" - for arg, val in vars(args).items() - ] - ) - logging.info("Running %s", cmd) - - # Check - if args.g == 1 or args.g < 0: - logging.critical("-g must be 0 or greater than 1.") - sys.exit() - - # Find placements for each node - nodes_mapper = _mkslurm_alt(args) - - # Group identical nodes: HetJob setup - hetjob_mapper = _group_identical_nodes(nodes_mapper) - - # Print table - _print_table(hetjob_mapper, args.N) - - # Build slurm script - - # Main job settings - - # Hetjobs settings - totn=0 - for het_group, values in hetjob_mapper.items(): - totn=totn + int(values['nnodes']) - - # Environment - - # Wrapper - exec_map = " ".join( - [ - str(e) - for values in hetjob_mapper.values() - for i in range(values["nnodes"]) - for e in values["ex"] - ] - ) - exec_cmd = "exec ${map[${exec_map[$SLURM_PROCID]}]}" - string = f"""\ - #!/bin/ksh - # - set -A map ./xios_server.exe ./nemo - exec_map=( {exec_map} ) - # - {exec_cmd} - ## - """ - slurm = dedent(string) - - # open myscript_wrapper.sh - file_out = open("myscript_wrapper.sh", "w") - - # write string to file - file_out.write(slurm) - - # close file - file_out.close() - - - # Srun - strings = [] - prev_nodes = 0 - for het_group, values in hetjob_mapper.items(): - het_group_string = ( - f"--het-group={het_group} --nodes={values['nnodes']}" - +f" --ntasks={values['nnodes']*len(values['ex'])}" - +f" --ntasks-per-node={len(values['ex'])}" if len(hetjob_mapper) > 1 else - f"--ntasks={values['nnodes']*len(values['ex'])}" - +f" --ntasks-per-node={len(values['ex'])}" - ) - strings += [ - f"{het_group_string} --cpu-bind=v,mask_cpu:" - + ",".join([hex(2 ** core) for core in values["pl"]]) - + " ./myscript_wrapper.sh" - ] - prev_nodes += values["nnodes"] - #slurm = "\nsrun --mem-bind=local \\\n" + " \\\n: ".join(strings) - slurm = "\nsrun --mem-bind=local " + " : ".join(strings) - - print(slurm) - - -def _mkslurm_alt(args): - """ - Python version of mkslurm_alt - - Args: - args: Parsed arguments. - - Returns: - Dictionary mapping nodes to their ex, pl - """ - - # Start loop - nservers_left = args.S - nclients_left = args.C - nodes_mapper = dict() - cpu, totnserv, prevclie, skipnext, node = (0 for _ in range(5)) - while nservers_left or nclients_left: - # Reset node - cpu = 0 if cpu == args.N else cpu - totnserv = totnserv if cpu else 0 - prevclie = prevclie if cpu else 0 - skipnext = skipnext if cpu else 0 - node = node if cpu else len(nodes_mapper) - if not cpu: - nodes_mapper[node] = dict(ex=[], pl=[]) - if skipnext: - skipnext -= 1 - cpu += 1 - prevclie = 0 - continue - if totnserv < args.m and nservers_left: - nodes_mapper[node]["ex"] += [0] - nodes_mapper[node]["pl"] += [cpu] - skipnext = args.s - 1 - nservers_left -= 1 - totnserv += 1 - elif nclients_left: - nodes_mapper[node]["ex"] += [1] - nodes_mapper[node]["pl"] += [cpu] - nclients_left -= 1 - prevclie += 1 - skipnext = prevclie == args.g - 1 - cpu += 1 - nodes_needed = len(nodes_mapper) - reserved_cores = nodes_needed * args.N - cores_used = sum(len(values["ex"]) for values in nodes_mapper.values()) - reserved_cores_needed = ( - args.S * args.s + args.C + (args.C // (args.g - 1) if args.g else 0) - ) - logging.info("nodes needed= %s (%s)", nodes_needed, reserved_cores) - logging.info("cores to be used= %s (%s)", cores_used, reserved_cores_needed) - - return nodes_mapper - - -def _group_identical_nodes(nodes_mapper): - """ - Group identical nodes to HetJobs - - Args: - nodes_mapper: Dictionary mapping nodes to their ex, pl - - Returns: - Dictionary mapping het-groups to their ex, pl, and nnodes - """ - # Group nodes for HetJob - hetjob_mapper = dict() - het_group = 0 - # Loop over nodes - for node_values in nodes_mapper.values(): - hetjob_found = False - # Loop over hetjobs already found - for hetjob, hetjob_values in hetjob_mapper.items(): - hetjob_found = all( - hetjob_values[key] == node_values[key] for key in ["ex", "pl"] - ) - if hetjob_found: - # Add to existing hetjob - hetjob_mapper[hetjob]["nnodes"] += 1 - break - # Create new hetjob - if not hetjob_found: - hetjob_mapper[het_group] = node_values - hetjob_mapper[het_group]["nnodes"] = 1 - het_group += 1 - - return dict(sorted(hetjob_mapper.items())) - - -def _print_table(hetjob_mapper, ncores_per_node): - """ - Print a human readable table of the setup. - - Args: - hetjob_mapper: Dictionary mapping het-groups to their ex, pl, and nnodes - ncores_per_node: Number of cores per node - """ - # Loop to create table - ex_list, pl_list, groups, nodes, cores, tasks = ([] for i in range(6)) - for group, values in enumerate(hetjob_mapper.values()): - ex_list += values["ex"] - pl_list += values["pl"] - nnodes = values["nnodes"] - # Build table - for core in range(ncores_per_node): - if core in values["pl"]: - task = "c" if values["ex"][values["pl"].index(core)] else "s" - groups += [group] - nodes += [nnodes] - cores += [core] - tasks += [task] - else: - groups += [group] - nodes += [nnodes] - cores += [core] - tasks += ["-"] - - # Print table - header = ("group", "nodes", "core", "task") - logging.debug("{:>5} {:>5} {:>5} {:>5}".format(*header)) - for line in zip(groups, nodes, cores, tasks): - logging.debug("{:>5} {:>5} {:>5} {:>5}".format(*line)) - - -if __name__ == "__main__": - # Parse arguments - parser = argparse.ArgumentParser( - prog="mkslurm_hetjob", - formatter_class=argparse.ArgumentDefaultsHelpFormatter, - description=" ".join( - [ - "Python version of mkslurm_alt by Andrew Coward using HetJob.", - "Server placement and spacing remains", - "as mkslurm but clients are always tightly packed with a gap left", - 'every "NC_GAP" cores where NC_GAP can be given by the -g argument.', - "values of 4, 8 or 16 are recommended.", - ] - ), - prefix_chars="-", - ) - parser.add_argument("-S", help="num_servers", type=int, default=4) - parser.add_argument("-s", help="server_spacing", type=int, default=8) - parser.add_argument("-m", help="max_servers_per_node", type=int, default=2) - parser.add_argument("-C", help="num_clients", type=int, default=28) - parser.add_argument("-g", help="client_gap_interval", type=int, default=4) - parser.add_argument("-N", help="ncores_per_node", type=int, default=128) - parser.add_argument("-t", help="time_limit", type=str, default="00:10:00") - parser.add_argument("-a", help="account", type=str, default="n01") - parser.add_argument("-j", help="job_name", type=str, default="nemo_test") - parser.add_argument("-v", help="show human readable hetjobs", action="store_true") - # Let's go! - main(parser.parse_args()) diff --git a/MY_SRC/.svn/all-wcprops b/MY_SRC/.svn/all-wcprops deleted file mode 100644 index 00fbfff..0000000 --- a/MY_SRC/.svn/all-wcprops +++ /dev/null @@ -1,17 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 102 -/nemo/svn/!svn/ver/9244/branches/UKMO/dev_r8814_surge_modelling_Nemo4/NEMOGCM/CONFIG/AMM7_SURGE/MY_SRC -END -usrdef_sbc.F90 -K 25 -svn:wc:ra_dav:version-url -V 117 -/nemo/svn/!svn/ver/9244/branches/UKMO/dev_r8814_surge_modelling_Nemo4/NEMOGCM/CONFIG/AMM7_SURGE/MY_SRC/usrdef_sbc.F90 -END -usrdef_istate.F90 -K 25 -svn:wc:ra_dav:version-url -V 120 -/nemo/svn/!svn/ver/9120/branches/UKMO/dev_r8814_surge_modelling_Nemo4/NEMOGCM/CONFIG/AMM7_SURGE/MY_SRC/usrdef_istate.F90 -END diff --git a/MY_SRC/.svn/entries b/MY_SRC/.svn/entries deleted file mode 100644 index b851634..0000000 --- a/MY_SRC/.svn/entries +++ /dev/null @@ -1,96 +0,0 @@ -10 - -dir -10357 -http://forge.ipsl.jussieu.fr/nemo/svn/branches/UKMO/dev_r8814_surge_modelling_Nemo4/NEMOGCM/CONFIG/AMM7_SURGE/MY_SRC -http://forge.ipsl.jussieu.fr/nemo/svn - - - -2018-01-16T15:33:58.957854Z -9244 -clne - - - - - - - - - - - - - - -4aad9cc9-4d31-0410-b1e8-ee312aa4b1ec - -usrdef_sbc.F90 -file - - - - -2018-11-23T10:56:48.000000Z -b4545bce5c099738c4cd804eb18348ae -2018-01-16T15:33:58.957854Z -9244 -clne - - - - - - - - - - - - - - - - - - - - - -14222 - -usrdef_istate.F90 -file - - - - -2018-11-23T10:56:48.000000Z -cd553f2c20a9311b9136a46091650456 -2017-12-18T17:29:02.797980Z -9120 -clne - - - - - - - - - - - - - - - - - - - - - -3625 - diff --git a/MY_SRC/.svn/text-base/usrdef_sbc.F90.svn-base b/MY_SRC/.svn/text-base/usrdef_sbc.F90.svn-base deleted file mode 100644 index 9c51862..0000000 --- a/MY_SRC/.svn/text-base/usrdef_sbc.F90.svn-base +++ /dev/null @@ -1,304 +0,0 @@ -MODULE usrdef_sbc - !!====================================================================== - !! *** MODULE usrdef_sbc *** - !! - !! === AMM7_SURGE configuration === - !! - !! User defined : surface forcing of a user configuration - !!====================================================================== - !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface - !! 4.0 ! 2017-12 (C. O'Neill) add necessary options for surge work - either no fluxes - !! (for tide-only run) or wind and pressure only - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! usr_def_sbc : user defined surface bounday conditions in LOCK_EXCHANGE case - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers - USE dom_oce ! ocean space and time domain - USE sbc_oce ! Surface boundary condition: ocean fields - USE sbc_ice ! Surface boundary condition: ocean fields - USE fldread ! read input fields - USE phycst ! physical constants - USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) - ! - USE in_out_manager ! I/O manager - USE iom - USE lib_mpp ! distribued memory computing library - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE wrk_nemo ! work arrays - USE timing ! Timing - USE prtctl ! Print control - - IMPLICIT NONE - PRIVATE - - PUBLIC usrdef_sbc_oce ! routine called in sbcmod module - PUBLIC usrdef_sbc_ice_tau ! routine called by sbcice_lim.F90 for ice dynamics - PUBLIC usrdef_sbc_ice_flx ! routine called by sbcice_lim.F90 for ice thermo - PUBLIC surge_oce ! routine called by usrdef_sbc_oce (if required) - - - INTEGER , PARAMETER :: jpfld = 2 ! maximum number of files to read - INTEGER , PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point - INTEGER , PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point - - TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) - - REAL(wp), PARAMETER :: rhoa = 1.22 ! air density - - ! !!* Namelist namsbc_usr - REAL(wp) :: rn_vfac ! multiplication factor for ice/ocean velocity in the calculation of wind stress (clem) - REAL(wp) :: rn_charn_const - LOGICAL :: ln_use_sbc ! Surface fluxes on or not - - - !! * Substitutions -# include "vectopt_loop_substitute.h90" - !!---------------------------------------------------------------------- - !! NEMO/OPA 4.0 , NEMO Consortium (2016) - !! $Id$ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE usrdef_sbc_oce( kt ) - !!--------------------------------------------------------------------- - !! *** ROUTINE usr_def_sbc *** - !! - !! ** Purpose : provide at each time-step the surface boundary - !! condition, i.e. the momentum, heat and freshwater fluxes. - !! - !! ** Method : all 0 fields, for AMM7_SURGE case - !! CAUTION : never mask the surface stress field ! - !! - !! ** Action : - if tide-only case - set to ZERO all the ocean surface boundary condition, i.e. - !! utau, vtau, taum, wndm, qns, qsr, emp, sfx - !! - if tide+surge case - read in wind and air pressure !! - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean time step - - INTEGER :: ierror ! return error code - INTEGER :: ifpr ! dummy loop indice - INTEGER :: ios ! Local integer output status for namelist read - ! - CHARACTER(len=100) :: cn_dir ! Root directory for location of flux files - TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read - TYPE(FLD_N) :: sn_wndi, sn_wndj ! informations about the fields to be read - - NAMELIST/namsbc_usr/ ln_use_sbc, cn_dir , rn_vfac, & - & sn_wndi, sn_wndj, rn_charn_const - !!--------------------------------------------------------------------- - ! - IF( kt == nit000 ) THEN - - - REWIND( numnam_cfg ) ! Namelist namsbc_usr in configuration namelist - READ ( numnam_cfg, namsbc_usr, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_surge in configuration namelist', lwp ) - - IF(lwm) WRITE( numond, namsbc_usr ) - - IF(ln_use_sbc) THEN - IF(lwp) WRITE(numout,*)' usr_sbc : AMM7_SURGE tide + surge case: surface wind and pressure (assuming ln_dyn_apr=T) applied' - IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ ' - - ! ! store namelist information in an array - slf_i(jp_wndi) = sn_wndi ; slf_i(jp_wndj) = sn_wndj - ! - ! - ALLOCATE( sf(jpfld), STAT=ierror ) ! set sf structure - IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_surge: unable to allocate sf structure' ) - DO ifpr= 1, jpfld - ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) - IF( slf_i(ifpr)%ln_tint ) ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) - END DO - ! ! fill sf with slf_i and control print - CALL fld_fill( sf, slf_i, cn_dir, 'sbc_surge', 'flux formulation for ocean surface boundary condition', 'namsbc_surge' ) - - ELSE - IF(lwp) WRITE(numout,*)' usr_sbc : AMM7_SURGE tide only case: NO surface forcing' - IF(lwp) WRITE(numout,*)' ~~~~~~~~~~~ utau = vtau = taum = wndm = qns = qsr = emp = sfx = 0' - - utau(:,:) = 0._wp - vtau(:,:) = 0._wp - taum(:,:) = 0._wp - wndm(:,:) = 0._wp - ! - emp (:,:) = 0._wp - sfx (:,:) = 0._wp - qns (:,:) = 0._wp - qsr (:,:) = 0._wp - ! - uwnd(:,:) = 0._wp - vwnd(:,:) = 0._wp - ENDIF - - ENDIF - ! - IF(ln_use_sbc) THEN - CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step - - ! ! compute the surface ocean fluxes using CORE bulk formulea - IF( MOD( kt - 1, nn_fsbc ) == 0 ) CALL surge_oce( kt, sf, ssu_m, ssv_m, rn_charn_const ) - - ENDIF - END SUBROUTINE usrdef_sbc_oce - - - - SUBROUTINE surge_oce( kt, sf, pu, pv, rn_charn_const ) - !!--------------------------------------------------------------------- - !! *** ROUTINE surge_oce *** - !! - !! ** Purpose : provide the momentum fluxes at - !! the ocean surface at each time step - !! - !! ** Method : Charnock formulea for the ocean using atmospheric - !! fields read in sbc_read - !! - !! ** 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) - !! - !! ** Nota : sf has to be a dummy argument for AGRIF on NEC - !!--------------------------------------------------------------------- - INTEGER , INTENT(in ) :: kt ! time step index - TYPE(fld), INTENT(inout), DIMENSION(:) :: sf ! input data - 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) :: rn_charn_const! local variable - ! - INTEGER :: ji, jj ! dummy loop indices - REAL(wp) :: zztmp ! local variable - REAL(wp) :: z_z0, z_Cd1 ! local variable - REAL(wp) :: zi ! local variable - REAL(wp), DIMENSION(:,:), POINTER :: zwnd_i, zwnd_j ! wind speed components at T-point - REAL(wp), DIMENSION(:,:), POINTER :: Cd ! transfer coefficient for momentum (tau) - !!--------------------------------------------------------------------- - ! - IF( nn_timing == 1 ) CALL timing_start('surge_oce') - ! - CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j ) - CALL wrk_alloc( jpi,jpj, Cd ) - ! - ! ----------------------------------------------------------------------------- ! - ! 0 Wind components and module at T-point relative to the moving ocean ! - ! ----------------------------------------------------------------------------- ! - - ! ... components ( U10m - U_oce ) at T-point (unmasked) - zwnd_i(:,:) = 0.e0 - zwnd_j(:,:) = 0.e0 - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vect. opt. - uwnd(ji,jj) = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj ) + pu(ji,jj) ) ) - vwnd(ji,jj) = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji ,jj-1) + pv(ji,jj) ) ) - END DO - END DO - zwnd_i(:,:) = uwnd(:,:) - zwnd_j(:,:) = vwnd(:,:) - - CALL lbc_lnk( zwnd_i(:,:) , 'T', -1. ) - CALL lbc_lnk( zwnd_j(:,:) , 'T', -1. ) - ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) - wndm(:,:) = SQRT( zwnd_i(:,:) * zwnd_i(:,:) & - & + zwnd_j(:,:) * zwnd_j(:,:) ) * tmask(:,:,1) - - ! ----------------------------------------------------------------------------- ! - ! I Radiative FLUXES ! - ! ----------------------------------------------------------------------------- ! - - qsr(:,:)=0._wp - - ! ----------------------------------------------------------------------------- ! - ! II Turbulent FLUXES ! - ! ----------------------------------------------------------------------------- ! - Cd(:,:)=0.0001_wp - DO jj = 1,jpj - DO ji = 1,jpi - z_Cd1=0._wp - zi=1 - !Iterate - DO WHILE((abs(Cd(ji,jj)-z_Cd1))>1E-6) - z_Cd1=Cd(ji,jj) - z_z0=rn_charn_const*z_Cd1*wndm(ji,jj)**2/grav - Cd(ji,jj)=(0.41_wp/log(10._wp/z_z0))**2 - zi=zi+1 - ENDDO - ENDDO - ENDDO - - ! ... tau module, i and j component - DO jj = 1, jpj - DO ji = 1, jpi - zztmp = rhoa * wndm(ji,jj) * Cd(ji,jj) - taum (ji,jj) = zztmp * wndm (ji,jj) - zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) - zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) - END DO - END DO - - CALL iom_put( "taum_oce", taum ) ! output wind stress module - CALL iom_put( "uwnd", uwnd ) ! output wind stress module - CALL iom_put( "vwnd", vwnd ) ! output wind stress module - - ! ... 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 the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves - DO jj = 1, jpjm1 - DO ji = 1, fs_jpim1 - utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) ) & - & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) - vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) ) & - & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) - END DO - END DO - CALL lbc_lnk( utau(:,:), 'U', -1. ) - CALL lbc_lnk( vtau(:,:), 'V', -1. ) - - - IF(ln_ctl) THEN - CALL prt_ctl( tab2d_1=utau , clinfo1=' surge_oce: utau : ', mask1=umask, & - & tab2d_2=vtau , clinfo2= ' vtau : ' , mask2=vmask ) - CALL prt_ctl( tab2d_1=wndm , clinfo1=' surge_oce: wndm : ') - ENDIF - - ! ----------------------------------------------------------------------------- ! - ! III Total FLUXES ! - ! ----------------------------------------------------------------------------- ! - ! - emp (:,:) = 0._wp - qns(:,:) = 0._wp - sfx(:,:) = 0._wp ! salt flux; zero unless ice is present (computed in limsbc(_2).F90) - ! -! IF ( nn_ice == 0 ) THEN -! 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(ln_ctl) THEN - CALL prt_ctl(tab2d_1=utau , clinfo1=' surge_oce: utau : ', mask1=umask, & - & tab2d_2=vtau , clinfo2= ' vtau : ' , mask2=vmask ) - ENDIF - ! - CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j ) - CALL wrk_dealloc( jpi,jpj, Cd ) - ! - IF( nn_timing == 1 ) CALL timing_stop('surge_oce') - - ! - END SUBROUTINE surge_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 ) - INTEGER, INTENT(in) :: kt ! ocean time step - END SUBROUTINE usrdef_sbc_ice_flx - - !!====================================================================== -END MODULE usrdef_sbc diff --git a/MY_SRC/bdyini.F90 b/MY_SRC/bdyini.F90 deleted file mode 100755 index ef881b0..0000000 --- a/MY_SRC/bdyini.F90 +++ /dev/null @@ -1,1743 +0,0 @@ -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 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 sbctide ! Tidal forcing or not - 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 - USE wrk_nemo ! Memory Allocation - USE timing ! Timing - - IMPLICIT NONE - PRIVATE - - PUBLIC bdy_init ! routine called in nemo_init - - INTEGER, PARAMETER :: jp_nseg = 100 ! - INTEGER, PARAMETER :: nrimmax = 20 ! maximum rimwidth in structured - ! open boundary data files - ! 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 ! - !!---------------------------------------------------------------------- - !! NEMO/OPA 3.7 , NEMO Consortium (2015) - !! $Id: bdyini.F90 7646 2017-02-06 09:25:03Z timgraham $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) - !!---------------------------------------------------------------------- -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_lim, nn_ice_lim_dta, & - & rn_ice_tem, rn_ice_sal, rn_ice_age, & - & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy - ! - INTEGER :: ios ! Local integer output status for namelist read - !!---------------------------------------------------------------------- - ! - IF( nn_timing == 1 ) CALL timing_start('bdy_init') - - ! ------------------------ - ! Read namelist parameters - ! ------------------------ - REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries - READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) - ! - REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries - READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp ) - IF(lwm) WRITE ( numond, nambdy ) - - ! ----------------------------------------- - ! 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_segs - ! - ! 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 - ! - IF( nn_timing == 1 ) CALL timing_stop('bdy_init') - ! - END SUBROUTINE bdy_init - - SUBROUTINE bdy_segs - !!---------------------------------------------------------------------- - !! *** 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 - !!---------------------------------------------------------------------- - - ! local variables - !------------------- - INTEGER :: ib_bdy, ii, ij, ik, igrd, ib, ir, iseg ! dummy loop indices - INTEGER :: icount, icountr, ibr_max, ilen1, ibm1 ! local integers - INTEGER :: iwe, ies, iso, ino, inum, id_dummy ! - - - INTEGER :: igrd_start, igrd_end, jpbdta ! - - - INTEGER :: jpbdtau, jpbdtas ! - - - INTEGER :: ib_bdy1, ib_bdy2, ib1, ib2 ! - - - INTEGER :: i_offset, j_offset ! - - - INTEGER , POINTER :: nbi, nbj, nbr ! short cuts - REAL(wp), POINTER :: flagu, flagv ! - - - REAL(wp), POINTER, DIMENSION(:,:) :: pmask ! pointer to 2D mask fields - REAL(wp) :: zefl, zwfl, znfl, zsfl ! local scalars - INTEGER, DIMENSION (2) :: 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 - INTEGER :: com_east, com_west, com_south, com_north ! Flags for boundaries sending - INTEGER :: com_east_b, com_west_b, com_south_b, com_north_b ! Flags for boundaries receiving - INTEGER :: iw_b(4), ie_b(4), is_b(4), in_b(4) ! Arrays for neighbours coordinates - REAL(wp), POINTER, DIMENSION(:,:) :: zfmask ! temporary fmask array excluding coastal boundary condition (shlat) - !! - CHARACTER(LEN=1) :: ctypebdy ! - - - INTEGER :: nbdyind, nbdybeg, nbdyend - !! - NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend - INTEGER :: ios ! Local integer output status for namelist read - !!---------------------------------------------------------------------- - ! - IF( nn_timing == 1 ) CALL timing_start('bdy_segs') - ! - cgrid = (/'t','u','v'/) - - ! ----------------------------------------- - ! Check and write out namelist parameters - ! ----------------------------------------- -! IF( jperio /= 0 ) CALL ctl_stop( 'bdy_segs: Cyclic or symmetric,', & -! & ' and general open boundary condition are not compatible' ) - - IF( nb_bdy == 0 ) THEN - IF(lwp) WRITE(numout,*) 'nb_bdy = 0, NO OPEN BOUNDARIES APPLIED.' - ELSE - IF(lwp) WRITE(numout,*) 'Number of open boundary sets : ', nb_bdy - ENDIF - - DO ib_bdy = 1,nb_bdy - IF(lwp) WRITE(numout,*) ' ' - IF(lwp) WRITE(numout,*) '------ Open boundary data set ',ib_bdy,'------' - - IF( ln_coords_file(ib_bdy) ) THEN - IF(lwp) WRITE(numout,*) 'Boundary definition read from file '//TRIM(cn_coords_file(ib_bdy)) - ELSE - IF(lwp) WRITE(numout,*) 'Boundary defined in namelist.' - ENDIF - IF(lwp) WRITE(numout,*) - - IF(lwp) WRITE(numout,*) 'Boundary conditions for barotropic solution: ' - SELECT CASE( cn_dyn2d(ib_bdy) ) - CASE( 'none' ) - IF(lwp) WRITE(numout,*) ' no open boundary condition' - dta_bdy(ib_bdy)%ll_ssh = .false. - dta_bdy(ib_bdy)%ll_u2d = .false. - dta_bdy(ib_bdy)%ll_v2d = .false. - CASE( 'frs' ) - IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' - dta_bdy(ib_bdy)%ll_ssh = .false. - dta_bdy(ib_bdy)%ll_u2d = .true. - dta_bdy(ib_bdy)%ll_v2d = .true. - CASE( 'flather' ) - IF(lwp) WRITE(numout,*) ' Flather radiation condition' - dta_bdy(ib_bdy)%ll_ssh = .true. - dta_bdy(ib_bdy)%ll_u2d = .true. - dta_bdy(ib_bdy)%ll_v2d = .true. - CASE( 'orlanski' ) - IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' - dta_bdy(ib_bdy)%ll_ssh = .false. - dta_bdy(ib_bdy)%ll_u2d = .true. - dta_bdy(ib_bdy)%ll_v2d = .true. - CASE( 'orlanski_npo' ) - IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' - dta_bdy(ib_bdy)%ll_ssh = .false. - dta_bdy(ib_bdy)%ll_u2d = .true. - dta_bdy(ib_bdy)%ll_v2d = .true. - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn2d' ) - END SELECT - IF( cn_dyn2d(ib_bdy) /= 'none' ) THEN - SELECT CASE( nn_dyn2d_dta(ib_bdy) ) ! - CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' - CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' tidal harmonic forcing taken from file' - CASE( 3 ) ; IF(lwp) 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 - IF (( 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 - ENDIF - IF(lwp) WRITE(numout,*) - - IF(lwp) WRITE(numout,*) 'Boundary conditions for baroclinic velocities: ' - SELECT CASE( cn_dyn3d(ib_bdy) ) - CASE('none') - IF(lwp) WRITE(numout,*) ' no open boundary condition' - dta_bdy(ib_bdy)%ll_u3d = .false. - dta_bdy(ib_bdy)%ll_v3d = .false. - CASE('frs') - IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' - dta_bdy(ib_bdy)%ll_u3d = .true. - dta_bdy(ib_bdy)%ll_v3d = .true. - CASE('specified') - IF(lwp) WRITE(numout,*) ' Specified value' - dta_bdy(ib_bdy)%ll_u3d = .true. - dta_bdy(ib_bdy)%ll_v3d = .true. - CASE('neumann') - IF(lwp) WRITE(numout,*) ' Neumann conditions' - dta_bdy(ib_bdy)%ll_u3d = .false. - dta_bdy(ib_bdy)%ll_v3d = .false. - CASE('zerograd') - IF(lwp) WRITE(numout,*) ' Zero gradient for baroclinic velocities' - dta_bdy(ib_bdy)%ll_u3d = .false. - dta_bdy(ib_bdy)%ll_v3d = .false. - CASE('zero') - IF(lwp) WRITE(numout,*) ' Zero baroclinic velocities (runoff case)' - dta_bdy(ib_bdy)%ll_u3d = .false. - dta_bdy(ib_bdy)%ll_v3d = .false. - CASE('orlanski') - IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' - dta_bdy(ib_bdy)%ll_u3d = .true. - dta_bdy(ib_bdy)%ll_v3d = .true. - CASE('orlanski_npo') - IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' - dta_bdy(ib_bdy)%ll_u3d = .true. - dta_bdy(ib_bdy)%ll_v3d = .true. - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_dyn3d' ) - END SELECT - IF( cn_dyn3d(ib_bdy) /= 'none' ) THEN - SELECT CASE( nn_dyn3d_dta(ib_bdy) ) ! - CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' - CASE DEFAULT ; CALL ctl_stop( 'nn_dyn3d_dta must be 0 or 1' ) - END SELECT - ENDIF - - 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((lwp).AND.rn_time_dmp(ib_bdy)<0) CALL ctl_stop( 'Time scale must be positive' ) - dta_bdy(ib_bdy)%ll_u3d = .true. - dta_bdy(ib_bdy)%ll_v3d = .true. - ENDIF - ELSE - IF(lwp) WRITE(numout,*) ' NO relaxation on baroclinic velocities' - ENDIF - IF(lwp) WRITE(numout,*) - - IF(lwp) WRITE(numout,*) 'Boundary conditions for temperature and salinity: ' - SELECT CASE( cn_tra(ib_bdy) ) - CASE('none') - IF(lwp) WRITE(numout,*) ' no open boundary condition' - dta_bdy(ib_bdy)%ll_tem = .false. - dta_bdy(ib_bdy)%ll_sal = .false. - CASE('frs') - IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' - dta_bdy(ib_bdy)%ll_tem = .true. - dta_bdy(ib_bdy)%ll_sal = .true. - CASE('specified') - IF(lwp) WRITE(numout,*) ' Specified value' - dta_bdy(ib_bdy)%ll_tem = .true. - dta_bdy(ib_bdy)%ll_sal = .true. - CASE('neumann') - IF(lwp) WRITE(numout,*) ' Neumann conditions' - dta_bdy(ib_bdy)%ll_tem = .false. - dta_bdy(ib_bdy)%ll_sal = .false. - CASE('runoff') - IF(lwp) WRITE(numout,*) ' Runoff conditions : Neumann for T and specified to 0.1 for salinity' - dta_bdy(ib_bdy)%ll_tem = .false. - dta_bdy(ib_bdy)%ll_sal = .false. - CASE('orlanski') - IF(lwp) WRITE(numout,*) ' Orlanski (fully oblique) radiation condition with adaptive nudging' - dta_bdy(ib_bdy)%ll_tem = .true. - dta_bdy(ib_bdy)%ll_sal = .true. - CASE('orlanski_npo') - IF(lwp) WRITE(numout,*) ' Orlanski (NPO) radiation condition with adaptive nudging' - dta_bdy(ib_bdy)%ll_tem = .true. - dta_bdy(ib_bdy)%ll_sal = .true. - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_tra' ) - END SELECT - IF( cn_tra(ib_bdy) /= 'none' ) THEN - SELECT CASE( nn_tra_dta(ib_bdy) ) ! - CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; IF(lwp) 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)%ll_tem = .true. - dta_bdy(ib_bdy)%ll_sal = .true. - ENDIF - ELSE - IF(lwp) WRITE(numout,*) ' NO T/S relaxation' - ENDIF - IF(lwp) WRITE(numout,*) - -#if defined key_lim2 - IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' - SELECT CASE( cn_ice_lim(ib_bdy) ) - CASE('none') - IF(lwp) WRITE(numout,*) ' no open boundary condition' - dta_bdy(ib_bdy)%ll_frld = .false. - dta_bdy(ib_bdy)%ll_hicif = .false. - dta_bdy(ib_bdy)%ll_hsnif = .false. - CASE('frs') - IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' - dta_bdy(ib_bdy)%ll_frld = .true. - dta_bdy(ib_bdy)%ll_hicif = .true. - dta_bdy(ib_bdy)%ll_hsnif = .true. - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) - END SELECT - IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN - SELECT CASE( nn_ice_lim_dta(ib_bdy) ) ! - CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' - CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) - END SELECT - ENDIF - IF(lwp) WRITE(numout,*) -#elif defined key_lim3 - IF(lwp) WRITE(numout,*) 'Boundary conditions for sea ice: ' - SELECT CASE( cn_ice_lim(ib_bdy) ) - CASE('none') - IF(lwp) WRITE(numout,*) ' no open boundary condition' - dta_bdy(ib_bdy)%ll_a_i = .false. - dta_bdy(ib_bdy)%ll_ht_i = .false. - dta_bdy(ib_bdy)%ll_ht_s = .false. - CASE('frs') - IF(lwp) WRITE(numout,*) ' Flow Relaxation Scheme' - dta_bdy(ib_bdy)%ll_a_i = .true. - dta_bdy(ib_bdy)%ll_ht_i = .true. - dta_bdy(ib_bdy)%ll_ht_s = .true. - CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice_lim' ) - END SELECT - IF( cn_ice_lim(ib_bdy) /= 'none' ) THEN - SELECT CASE( nn_ice_lim_dta(ib_bdy) ) ! - CASE( 0 ) ; IF(lwp) WRITE(numout,*) ' initial state used for bdy data' - CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' boundary data taken from file' - CASE DEFAULT ; CALL ctl_stop( 'nn_ice_lim_dta must be 0 or 1' ) - END SELECT - ENDIF - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' tem of bdy sea-ice = ', rn_ice_tem(ib_bdy) - IF(lwp) WRITE(numout,*) ' sal of bdy sea-ice = ', rn_ice_sal(ib_bdy) - IF(lwp) WRITE(numout,*) ' age of bdy sea-ice = ', rn_ice_age(ib_bdy) -#endif - - IF(lwp) WRITE(numout,*) ' Width of relaxation zone = ', nn_rimwidth(ib_bdy) - IF(lwp) WRITE(numout,*) - - ENDDO - - IF (nb_bdy .gt. 0) THEN - IF( ln_vol ) THEN ! check volume conservation (nn_volctl value) - IF(lwp) WRITE(numout,*) 'Volume correction applied at open boundaries' - IF(lwp) WRITE(numout,*) - SELECT CASE ( nn_volctl ) - CASE( 1 ) ; IF(lwp) WRITE(numout,*) ' The total volume will be constant' - CASE( 0 ) ; IF(lwp) 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 - IF(lwp) WRITE(numout,*) - ELSE - IF(lwp) WRITE(numout,*) 'No volume correction applied at open boundaries' - IF(lwp) WRITE(numout,*) - ENDIF - IF( nb_jpk_bdy > 0 ) THEN - IF(lwp) WRITE(numout,*) '*** open boundary will be interpolate in the vertical onto the native grid ***' - ELSE - IF(lwp) WRITE(numout,*) '*** open boundary will be read straight onto the native grid without vertical interpolation ***' - ENDIF - ENDIF - - ! ------------------------------------------------- - ! Initialise indices arrays for open boundaries - ! ------------------------------------------------- - - ! Work out global dimensions of boundary data - ! --------------------------------------------- - REWIND( numnam_cfg ) - - nblendta(:,:) = 0 - nbdysege = 0 - nbdysegw = 0 - nbdysegn = 0 - nbdysegs = 0 - icount = 0 ! count user defined segments - ! Dimensions below are used to allocate arrays to read external data - jpbdtas = 1 ! Maximum size of boundary data (structured case) - jpbdtau = 1 ! Maximum size of boundary data (unstructured case) - - DO ib_bdy = 1, nb_bdy - - IF( .NOT. ln_coords_file(ib_bdy) ) THEN ! Work out size of global arrays from namelist parameters - - icount = icount + 1 - ! No REWIND here because may need to read more than one nambdy_index namelist. - ! Read only namelist_cfg to avoid unseccessfull overwrite -!! REWIND( numnam_ref ) ! Namelist nambdy_index in reference namelist : Open boundaries indexes -!! READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 903) -!!903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in reference namelist', lwp ) - -!! REWIND( numnam_cfg ) ! Namelist nambdy_index in configuration namelist : Open boundaries indexes - READ ( numnam_cfg, nambdy_index, IOSTAT = ios, ERR = 904 ) -904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_index in configuration namelist', lwp ) - IF(lwm) WRITE ( numond, nambdy_index ) - - SELECT CASE ( TRIM(ctypebdy) ) - CASE( 'N' ) - IF( nbdyind == -1 ) THEN ! Automatic boundary definition: if nbdysegX = -1 - nbdyind = jpjglo - 2 ! set boundary to whole side of model domain. - nbdybeg = 2 - nbdyend = jpiglo - 1 - ENDIF - nbdysegn = nbdysegn + 1 - npckgn(nbdysegn) = ib_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 = jpiglo - 1 - ENDIF - nbdysegs = nbdysegs + 1 - npckgs(nbdysegs) = ib_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 = jpiglo - 2 ! set boundary to whole side of model domain. - nbdybeg = 2 - nbdyend = jpjglo - 1 - ENDIF - nbdysege = nbdysege + 1 - npckge(nbdysege) = ib_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 = jpjglo - 1 - ENDIF - nbdysegw = nbdysegw + 1 - npckgw(nbdysegw) = ib_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) - - nblendta(1:jpbgrd,ib_bdy) = (nbdyend - nbdybeg + 1) * nn_rimwidth(ib_bdy) - jpbdtas = MAX(jpbdtas, (nbdyend - nbdybeg + 1)) - IF (lwp.and.(nn_rimwidth(ib_bdy)>nrimmax)) & - & CALL ctl_stop( 'rimwidth must be lower than nrimmax' ) - - 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 ) - !clem nblendta(igrd,ib_bdy) = kdimsz(1) - !clem jpbdtau = MAX(jpbdtau, kdimsz(1)) - nblendta(igrd,ib_bdy) = MAXVAL(kdimsz) - jpbdtau = MAX(jpbdtau, MAXVAL(kdimsz)) - END DO - CALL iom_close( inum ) - ! - ENDIF - ! - END DO ! ib_bdy - - IF (nb_bdy>0) THEN - jpbdta = MAXVAL(nblendta(1:jpbgrd,1:nb_bdy)) - - ! Allocate arrays - !--------------- - ALLOCATE( nbidta(jpbdta, jpbgrd, nb_bdy), nbjdta(jpbdta, jpbgrd, nb_bdy), & - & nbrdta(jpbdta, jpbgrd, nb_bdy) ) - - IF( nb_jpk_bdy>0 ) THEN - ALLOCATE( dta_global(jpbdtau, 1, nb_jpk_bdy) ) - ALLOCATE( dta_global_z(jpbdtau, 1, nb_jpk_bdy) ) - ALLOCATE( dta_global_dz(jpbdtau, 1, nb_jpk_bdy) ) - ELSE - ALLOCATE( dta_global(jpbdtau, 1, jpk) ) - ALLOCATE( dta_global_z(jpbdtau, 1, jpk) ) ! needed ?? TODO - ALLOCATE( dta_global_dz(jpbdtau, 1, jpk) )! needed ?? TODO - ENDIF - - IF ( icount>0 ) THEN - IF( nb_jpk_bdy>0 ) THEN - ALLOCATE( dta_global2(jpbdtas, nrimmax, nb_jpk_bdy) ) - ALLOCATE( dta_global2_z(jpbdtas, nrimmax, nb_jpk_bdy) ) - ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, nb_jpk_bdy) ) - ELSE - ALLOCATE( dta_global2(jpbdtas, nrimmax, jpk) ) - ALLOCATE( dta_global2_z(jpbdtas, nrimmax, jpk) ) ! needed ?? TODO - ALLOCATE( dta_global2_dz(jpbdtas, nrimmax, jpk) )! needed ?? TODO - ENDIF - ENDIF - ! - ENDIF - - ! Now look for crossings in user (namelist) defined open boundary segments: - !-------------------------------------------------------------------------- - IF( icount>0 ) CALL bdy_ctl_seg - - ! 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 - ! - CALL iom_open( cn_coords_file(ib_bdy), inum ) - DO igrd = 1, jpbgrd - CALL iom_get( inum, jpdom_unknown, 'nbi'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) - DO ii = 1,nblendta(igrd,ib_bdy) - nbidta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) - END DO - CALL iom_get( inum, jpdom_unknown, 'nbj'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) - DO ii = 1,nblendta(igrd,ib_bdy) - nbjdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,1) ) - END DO - CALL iom_get( inum, jpdom_unknown, 'nbr'//cgrid(igrd), dta_global(1:nblendta(igrd,ib_bdy),:,1) ) - DO ii = 1,nblendta(igrd,ib_bdy) - nbrdta(ii,igrd,ib_bdy) = INT( dta_global(ii,1,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 ) - ! - ENDIF - ! - END DO - - ! 2. Now fill indices corresponding to straight open boundary arrays: - ! 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 - nbjdta(icount, igrd, ib_bdy) = ij - 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 - nbjdta(icount, igrd, ib_bdy) = ij - 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 - nbjdta(icount, igrd, ib_bdy) = ij - 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 - nbjdta(icount, igrd, ib_bdy) = ij - 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 - nbjdta(icount, igrd, ib_bdy) = ij - 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 - nbjdta(icount, igrd, ib_bdy) = ij - 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 - nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir - 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 - nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir - 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 - nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir - 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 - nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 - 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 - nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 - 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 - nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 - nbrdta(icount, igrd, ib_bdy) = ir - ENDDO - ENDDO - ENDDO - - ! 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 - - ! Work out dimensions of boundary data on each processor - ! ------------------------------------------------------ - - ! Rather assume that boundary data indices are given on global domain - ! TO BE DISCUSSED ? -! iw = mig(1) + 1 ! if monotasking and no zoom, iw=2 -! ie = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 -! is = mjg(1) + 1 ! if monotasking and no zoom, is=2 -! in = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 - iwe = mig(1) - 1 + 2 ! if monotasking and no zoom, iw=2 - ies = mig(1) + nlci-1 - 1 ! if monotasking and no zoom, ie=jpim1 - iso = mjg(1) - 1 + 2 ! if monotasking and no zoom, is=2 - ino = mjg(1) + nlcj-1 - 1 ! if monotasking and no zoom, in=jpjm1 - - ALLOCATE( nbondi_bdy(nb_bdy)) - ALLOCATE( nbondj_bdy(nb_bdy)) - nbondi_bdy(:)=2 - nbondj_bdy(:)=2 - ALLOCATE( nbondi_bdy_b(nb_bdy)) - ALLOCATE( nbondj_bdy_b(nb_bdy)) - nbondi_bdy_b(:)=2 - nbondj_bdy_b(:)=2 - - ! Work out dimensions of boundary data on each neighbour process - IF(nbondi == 0) THEN - iw_b(1) = 1 + nimppt(nowe+1) - ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 - is_b(1) = 1 + njmppt(nowe+1) - in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 - - iw_b(2) = 1 + nimppt(noea+1) - ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 - is_b(2) = 1 + njmppt(noea+1) - in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 - ELSEIF(nbondi == 1) THEN - iw_b(1) = 1 + nimppt(nowe+1) - ie_b(1) = 1 + nimppt(nowe+1)+nlcit(nowe+1)-3 - is_b(1) = 1 + njmppt(nowe+1) - in_b(1) = 1 + njmppt(nowe+1)+nlcjt(nowe+1)-3 - ELSEIF(nbondi == -1) THEN - iw_b(2) = 1 + nimppt(noea+1) - ie_b(2) = 1 + nimppt(noea+1)+nlcit(noea+1)-3 - is_b(2) = 1 + njmppt(noea+1) - in_b(2) = 1 + njmppt(noea+1)+nlcjt(noea+1)-3 - ENDIF - - IF(nbondj == 0) THEN - iw_b(3) = 1 + nimppt(noso+1) - ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 - is_b(3) = 1 + njmppt(noso+1) - in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 - - iw_b(4) = 1 + nimppt(nono+1) - ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 - is_b(4) = 1 + njmppt(nono+1) - in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 - ELSEIF(nbondj == 1) THEN - iw_b(3) = 1 + nimppt(noso+1) - ie_b(3) = 1 + nimppt(noso+1)+nlcit(noso+1)-3 - is_b(3) = 1 + njmppt(noso+1) - in_b(3) = 1 + njmppt(noso+1)+nlcjt(noso+1)-3 - ELSEIF(nbondj == -1) THEN - iw_b(4) = 1 + nimppt(nono+1) - ie_b(4) = 1 + nimppt(nono+1)+nlcit(nono+1)-3 - is_b(4) = 1 + njmppt(nono+1) - in_b(4) = 1 + njmppt(nono+1)+nlcjt(nono+1)-3 - ENDIF - - DO ib_bdy = 1, nb_bdy - DO igrd = 1, jpbgrd - icount = 0 - icountr = 0 - idx_bdy(ib_bdy)%nblen(igrd) = 0 - idx_bdy(ib_bdy)%nblenrim(igrd) = 0 - DO ib = 1, nblendta(igrd,ib_bdy) - ! check that data is in correct order in file - ibm1 = MAX(1,ib-1) - IF(lwp) THEN ! Since all procs read global data only need to do this check on one proc... - IF( nbrdta(ib,igrd,ib_bdy) < nbrdta(ibm1,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 ) icountr = icountr+1 - ENDIF - ENDDO - idx_bdy(ib_bdy)%nblenrim(igrd) = icountr !: length of rim boundary data on each proc - idx_bdy(ib_bdy)%nblen (igrd) = icount !: length of boundary data on each proc - ENDDO ! igrd - - ! Allocate index arrays for this boundary set - !-------------------------------------------- - ilen1 = MAXVAL( idx_bdy(ib_bdy)%nblen(:) ) - ALLOCATE( idx_bdy(ib_bdy)%nbi (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%nbj (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%nbr (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%nbd (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%nbdout(ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%nbmap (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%nbw (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%flagu (ilen1,jpbgrd) ) - ALLOCATE( idx_bdy(ib_bdy)%flagv (ilen1,jpbgrd) ) - - ! Dispatch mapping indices and discrete distances on each processor - ! ----------------------------------------------------------------- - - com_east = 0 - com_west = 0 - com_south = 0 - com_north = 0 - - com_east_b = 0 - com_west_b = 0 - com_south_b = 0 - com_north_b = 0 - - DO igrd = 1, jpbgrd - icount = 0 - ! Loop on rimwidth to ensure outermost points come first in the local arrays. - DO ir=1, 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 - - ! Rather assume that boundary data indices are given on global domain - ! TO BE DISCUSSED ? -! idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 -! idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 - idx_bdy(ib_bdy)%nbi(icount,igrd) = nbidta(ib,igrd,ib_bdy)- mig(1)+1 - idx_bdy(ib_bdy)%nbj(icount,igrd) = nbjdta(ib,igrd,ib_bdy)- mjg(1)+1 - ! check if point has to be sent - ii = idx_bdy(ib_bdy)%nbi(icount,igrd) - ij = idx_bdy(ib_bdy)%nbj(icount,igrd) - if((com_east .ne. 1) .and. (ii == (nlci-1)) .and. (nbondi .le. 0)) then - com_east = 1 - elseif((com_west .ne. 1) .and. (ii == 2) .and. (nbondi .ge. 0) .and. (nbondi .ne. 2)) then - com_west = 1 - endif - if((com_south .ne. 1) .and. (ij == 2) .and. (nbondj .ge. 0) .and. (nbondj .ne. 2)) then - com_south = 1 - elseif((com_north .ne. 1) .and. (ij == (nlcj-1)) .and. (nbondj .le. 0)) then - com_north = 1 - endif - idx_bdy(ib_bdy)%nbr(icount,igrd) = nbrdta(ib,igrd,ib_bdy) - idx_bdy(ib_bdy)%nbmap(icount,igrd) = ib - ENDIF - ! check if point has to be received from a neighbour - IF(nbondi == 0) THEN - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 - if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then - ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 - if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then - com_south = 1 - elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then - com_north = 1 - endif - com_west_b = 1 - endif - ENDIF - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 - if((com_east_b .ne. 1) .and. (ii == 2)) then - ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 - if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then - com_south = 1 - elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then - com_north = 1 - endif - com_east_b = 1 - endif - ENDIF - ELSEIF(nbondi == 1) THEN - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(1) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(1) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(1) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(1) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ii = nbidta(ib,igrd,ib_bdy)- iw_b(1)+2 - if((com_west_b .ne. 1) .and. (ii == (nlcit(nowe+1)-1))) then - ij = nbjdta(ib,igrd,ib_bdy) - is_b(1)+2 - if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then - com_south = 1 - elseif((ij == nlcjt(nowe+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then - com_north = 1 - endif - com_west_b = 1 - endif - ENDIF - ELSEIF(nbondi == -1) THEN - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(2) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(2) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(2) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(2) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ii = nbidta(ib,igrd,ib_bdy)- iw_b(2)+2 - if((com_east_b .ne. 1) .and. (ii == 2)) then - ij = nbjdta(ib,igrd,ib_bdy) - is_b(2)+2 - if((ij == 2) .and. (nbondj == 0 .or. nbondj == 1)) then - com_south = 1 - elseif((ij == nlcjt(noea+1)-1) .and. (nbondj == 0 .or. nbondj == -1)) then - com_north = 1 - endif - com_east_b = 1 - endif - ENDIF - ENDIF - IF(nbondj == 0) THEN - IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 & - & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & - & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN - com_north_b = 1 - ENDIF - IF(com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 & - &.OR. nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & - & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN - com_south_b = 1 - ENDIF - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 - if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then - com_south_b = 1 - endif - ENDIF - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 - if((com_north_b .ne. 1) .and. (ij == 2)) then - com_north_b = 1 - endif - ENDIF - ELSEIF(nbondj == 1) THEN - IF( com_south_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(3)-1 .OR. & - & nbidta(ib,igrd,ib_bdy) == ie_b(3)+1) .AND. & - & nbjdta(ib,igrd,ib_bdy) == in_b(3) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN - com_south_b = 1 - ENDIF - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(3) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(3) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(3) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(3) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ij = nbjdta(ib,igrd,ib_bdy)- is_b(3)+2 - if((com_south_b .ne. 1) .and. (ij == (nlcjt(noso+1)-1))) then - com_south_b = 1 - endif - ENDIF - ELSEIF(nbondj == -1) THEN - IF(com_north_b .ne. 1 .AND. (nbidta(ib,igrd,ib_bdy) == iw_b(4)-1 & - & .OR. nbidta(ib,igrd,ib_bdy) == ie_b(4)+1) .AND. & - & nbjdta(ib,igrd,ib_bdy) == is_b(4) .AND. nbrdta(ib,igrd,ib_bdy) == ir) THEN - com_north_b = 1 - ENDIF - IF( nbidta(ib,igrd,ib_bdy) >= iw_b(4) .AND. nbidta(ib,igrd,ib_bdy) <= ie_b(4) .AND. & - & nbjdta(ib,igrd,ib_bdy) >= is_b(4) .AND. nbjdta(ib,igrd,ib_bdy) <= in_b(4) .AND. & - & nbrdta(ib,igrd,ib_bdy) == ir ) THEN - ij = nbjdta(ib,igrd,ib_bdy)- is_b(4)+2 - if((com_north_b .ne. 1) .and. (ij == 2)) then - com_north_b = 1 - endif - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - - ! definition of the i- and j- direction local boundaries arrays used for sending the boundaries - IF( (com_east == 1) .and. (com_west == 1) ) THEN ; nbondi_bdy(ib_bdy) = 0 - ELSEIF( (com_east == 1) .and. (com_west == 0) ) THEN ; nbondi_bdy(ib_bdy) = -1 - ELSEIF( (com_east == 0) .and. (com_west == 1) ) THEN ; nbondi_bdy(ib_bdy) = 1 - ENDIF - IF( (com_north == 1) .and. (com_south == 1) ) THEN ; nbondj_bdy(ib_bdy) = 0 - ELSEIF( (com_north == 1) .and. (com_south == 0) ) THEN ; nbondj_bdy(ib_bdy) = -1 - ELSEIF( (com_north == 0) .and. (com_south == 1) ) THEN ; nbondj_bdy(ib_bdy) = 1 - ENDIF - - ! definition of the i- and j- direction local boundaries arrays used for receiving the boundaries - IF( (com_east_b == 1) .and. (com_west_b == 1) ) THEN ; nbondi_bdy_b(ib_bdy) = 0 - ELSEIF( (com_east_b == 1) .and. (com_west_b == 0) ) THEN ; nbondi_bdy_b(ib_bdy) = -1 - ELSEIF( (com_east_b == 0) .and. (com_west_b == 1) ) THEN ; nbondi_bdy_b(ib_bdy) = 1 - ENDIF - IF( (com_north_b == 1) .and. (com_south_b == 1) ) THEN ; nbondj_bdy_b(ib_bdy) = 0 - ELSEIF( (com_north_b == 1) .and. (com_south_b == 0) ) THEN ; nbondj_bdy_b(ib_bdy) = -1 - ELSEIF( (com_north_b == 0) .and. (com_south_b == 1) ) THEN ; nbondj_bdy_b(ib_bdy) = 1 - ENDIF - - ! Compute rim weights for FRS scheme - ! ---------------------------------- - DO igrd = 1, jpbgrd - DO ib = 1, idx_bdy(ib_bdy)%nblen(igrd) - nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) - idx_bdy(ib_bdy)%nbw(ib,igrd) = 1.- TANH( REAL( nbr - 1 ) *0.5 ) ! tanh formulation -! idx_bdy(ib_bdy)%nbw(ib,igrd) = (REAL(nn_rimwidth(ib_bdy)+1-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic -! idx_bdy(ib_bdy)%nbw(ib,igrd) = REAL(nn_rimwidth(ib_bdy)+1-nbr)/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) - nbr => idx_bdy(ib_bdy)%nbr(ib,igrd) - idx_bdy(ib_bdy)%nbd(ib,igrd) = 1. / ( rn_time_dmp(ib_bdy) * rday ) & - & *(REAL(nn_rimwidth(ib_bdy)+1-nbr)/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-nbr)/REAL(nn_rimwidth(ib_bdy)))**2. ! quadratic - END DO - END DO - - ENDDO - - ! ------------------------------------------------------ - ! Initialise masks and find normal/tangential directions - ! ------------------------------------------------------ - - ! Read global 2D mask at T-points: bdytmask - ! ----------------------------------------- - ! bdytmask = 1 on the computational domain AND on open boundaries - ! = 0 elsewhere - - bdytmask(:,:) = ssmask(:,:) - - ! we need to derive mask on U and V grid from mask on T grid here. - bdyumask(:,:) = 0._wp - bdyvmask(:,:) = 0._wp - DO ij = 1, jpjm1 - DO ii = 1, jpim1 - bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1, ij ) - bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii ,ij+1) - END DO - END DO - CALL lbc_lnk( bdyumask(:,:), 'U', 1. ) ; CALL lbc_lnk( bdyvmask(:,:), 'V', 1. ) ! Lateral boundary cond. - - ! bdy masks are now set to zero on boundary points: - ! - igrd = 1 - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) - bdytmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp - END DO - END DO - ! - igrd = 2 - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) - bdyumask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp - END DO - END DO - ! - igrd = 3 - DO ib_bdy = 1, nb_bdy - DO ib = 1, idx_bdy(ib_bdy)%nblenrim(igrd) - bdyvmask(idx_bdy(ib_bdy)%nbi(ib,igrd), idx_bdy(ib_bdy)%nbj(ib,igrd)) = 0._wp - ENDDO - ENDDO - - ! For the flagu/flagv calculation below we require a version of fmask without - ! the land boundary condition (shlat) included: - CALL wrk_alloc(jpi,jpj, zfmask ) - DO ij = 2, jpjm1 - DO ii = 2, jpim1 - zfmask(ii,ij) = tmask(ii,ij ,1) * tmask(ii+1,ij ,1) & - & * tmask(ii,ij+1,1) * tmask(ii+1,ij+1,1) - END DO - END DO - - ! Lateral boundary conditions - CALL lbc_lnk( zfmask , 'F', 1. ) - CALL lbc_lnk( fmask , 'F', 1. ) ; CALL lbc_lnk( bdytmask(:,:), 'T', 1. ) - CALL lbc_lnk( bdyumask(:,:), 'U', 1. ) ; CALL lbc_lnk( bdyvmask(:,:), 'V', 1. ) - - DO ib_bdy = 1, nb_bdy ! Indices and directions of rim velocity components - - idx_bdy(ib_bdy)%flagu(:,:) = 0._wp - idx_bdy(ib_bdy)%flagv(:,:) = 0._wp - icount = 0 - - ! 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 - - DO igrd = 1,jpbgrd - SELECT CASE( igrd ) - CASE( 1 ) ; pmask => umask (:,:,1) ; i_offset = 0 - CASE( 2 ) ; pmask => bdytmask(:,:) ; i_offset = 1 - CASE( 3 ) ; pmask => zfmask (:,:) ; i_offset = 0 - END SELECT - icount = 0 - 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) - zefl = pmask(nbi+i_offset-1,nbj) - zwfl = pmask(nbi+i_offset,nbj) - ! This error check only works if you are using the bdyXmask arrays - IF( i_offset == 1 .and. zefl + zwfl == 2 ) THEN - icount = icount + 1 - IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) - ELSE - idx_bdy(ib_bdy)%flagu(ib,igrd) = -zefl + zwfl - ENDIF - END DO - IF( icount /= 0 ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,', & - ' are not boundary points (flagu calculation). Check nbi, nbj, indices for boundary set ',ib_bdy - IF(lwp) WRITE(numout,*) ' ========== ' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ENDIF - 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 - - DO igrd = 1, jpbgrd - SELECT CASE( igrd ) - CASE( 1 ) ; pmask => vmask (:,:,1) ; j_offset = 0 - CASE( 2 ) ; pmask => zfmask(:,:) ; j_offset = 0 - CASE( 3 ) ; pmask => bdytmask ; j_offset = 1 - END SELECT - icount = 0 - 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) - znfl = pmask(nbi,nbj+j_offset-1) - zsfl = pmask(nbi,nbj+j_offset ) - ! This error check only works if you are using the bdyXmask arrays - IF( j_offset == 1 .and. znfl + zsfl == 2 ) THEN - IF(lwp) WRITE(numout,*) 'Problem with igrd = ',igrd,' at (global) nbi, nbj : ',mig(nbi),mjg(nbj) - icount = icount + 1 - ELSE - idx_bdy(ib_bdy)%flagv(ib,igrd) = -znfl + zsfl - END IF - END DO - IF( icount /= 0 ) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Some ',cgrid(igrd),' grid points,', & - ' are not boundary points (flagv calculation). Check nbi, nbj, indices for boundary set ',ib_bdy - IF(lwp) WRITE(numout,*) ' ========== ' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ENDIF - END DO - ! - END DO - - ! Compute total lateral surface for volume correction: - ! ---------------------------------------------------- - ! JC: this must be done at each time step with non-linear free surface - bdysurftot = 0._wp - IF( ln_vol ) THEN - 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) - flagu => idx_bdy(ib_bdy)%flagu(ib,igrd) - bdysurftot = bdysurftot + hu_n (nbi , nbj) & - & * e2u (nbi , nbj) * ABS( flagu ) & - & * 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) - flagv => idx_bdy(ib_bdy)%flagv(ib,igrd) - bdysurftot = bdysurftot + hv_n (nbi, nbj ) & - & * e1v (nbi, nbj ) * ABS( flagv ) & - & * tmask_i(nbi, nbj ) & - & * tmask_i(nbi, nbj+1) - END DO - END DO - ! - IF( lk_mpp ) CALL mpp_sum( bdysurftot ) ! sum over the global domain - END IF - ! - ! Tidy up - !-------- - IF( nb_bdy>0 ) DEALLOCATE( nbidta, nbjdta, nbrdta ) - ! - CALL wrk_dealloc(jpi,jpj, zfmask ) - ! - IF( nn_timing == 1 ) CALL timing_stop('bdy_segs') - ! - END SUBROUTINE bdy_segs - - 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.jpjglo-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).le.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpinft(ib).ge.jpiglo) 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.jpjglo-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).le.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpisft(ib).ge.jpiglo) 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.jpiglo-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).le.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpjeft(ib).ge.jpjglo) 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.jpiglo-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).le.1 ) CALL ctl_stop( 'Start index out of domain' ) - IF (jpjwft(ib).ge.jpjglo) 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 - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & - & jpisft(ib2), jpjwft(ib1) - IF(lwp) WRITE(numout,*) ' ========== Not allowed yet' - IF(lwp) WRITE(numout,*) ' Crossing problem with West segment: ',npckgw(ib1), & - & ' and South segment: ',npckgs(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ELSE - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Check South and West Open boundary indices' - IF(lwp) WRITE(numout,*) ' ========== Crossing problem with West segment: ',npckgw(ib1) , & - & ' and South segment: ',npckgs(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop+1 - 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 - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & - & jpisdt(ib2), jpjeft(ib1) - IF(lwp) WRITE(numout,*) ' ========== Not allowed yet' - IF(lwp) WRITE(numout,*) ' Crossing problem with East segment: ',npckge(ib1), & - & ' and South segment: ',npckgs(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ELSE - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Check South and East Open boundary indices' - IF(lwp) WRITE(numout,*) ' ========== Crossing problem with East segment: ',npckge(ib1), & - & ' and South segment: ',npckgs(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & - & jpinft(ib2), jpjwdt(ib1) - IF(lwp) WRITE(numout,*) ' ========== Not allowed yet' - IF(lwp) WRITE(numout,*) ' Crossing problem with West segment: ',npckgw(ib1), & - & ' and North segment: ',npckgn(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ELSE - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Check North and West Open boundary indices' - IF(lwp) WRITE(numout,*) ' ========== Crossing problem with West segment: ',npckgw(ib1), & - & ' and North segment: ',npckgn(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Found an acute open boundary corner at point (i,j)= ', & - & jpindt(ib2), jpjedt(ib1) - IF(lwp) WRITE(numout,*) ' ========== Not allowed yet' - IF(lwp) WRITE(numout,*) ' Crossing problem with East segment: ',npckge(ib1), & - & ' and North segment: ',npckgn(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ELSE - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Check North and East Open boundary indices' - IF(lwp) WRITE(numout,*) ' ========== Crossing problem with East segment: ',npckge(ib1), & - & ' and North segment: ',npckgn(ib2) - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 (((ji + nimpp - 1) == jpiwob(ib)).AND. & - & ((jj + njmpp - 1) == jpjwdt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & - & ((jj + njmpp - 1) == jpjwft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain - - IF (ztestmask(1)==1) THEN - IF (icornw(ib,1)==0) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgw(ib) - IF(lwp) WRITE(numout,*) ' ========== does not start on land or on a corner' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgw(ib) - IF(lwp) WRITE(numout,*) ' ========== does not end on land or on a corner' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 (((ji + nimpp - 1) == jpieob(ib)+1).AND. & - & ((jj + njmpp - 1) == jpjedt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & - & ((jj + njmpp - 1) == jpjeft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain - - IF (ztestmask(1)==1) THEN - IF (icorne(ib,1)==0) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckge(ib) - IF(lwp) WRITE(numout,*) ' ========== does not start on land or on a corner' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckge(ib) - IF(lwp) WRITE(numout,*) ' ========== does not end on land or on a corner' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 (((jj + njmpp - 1) == jpjsob(ib)).AND. & - & ((ji + nimpp - 1) == jpisdt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & - & ((ji + nimpp - 1) == jpisft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain - - IF ((ztestmask(1)==1).AND.(icorns(ib,1)==0)) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgs(ib) - IF(lwp) WRITE(numout,*) ' ========== does not start on land or on a corner' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ENDIF - IF ((ztestmask(2)==1).AND.(icorns(ib,2)==0)) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgs(ib) - IF(lwp) WRITE(numout,*) ' ========== does not end on land or on a corner' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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 (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & - & ((ji + nimpp - 1) == jpindt(ib))) ztestmask(1)=tmask(ji,jj,1) - IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & - & ((ji + nimpp - 1) == jpinft(ib))) ztestmask(2)=tmask(ji,jj,1) - END DO - END DO - IF( lk_mpp ) CALL mpp_sum( ztestmask, 2 ) ! sum over the global domain - - IF ((ztestmask(1)==1).AND.(icornn(ib,1)==0)) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgn(ib) - IF(lwp) WRITE(numout,*) ' ========== does not start on land' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ENDIF - IF ((ztestmask(2)==1).AND.(icornn(ib,2)==0)) THEN - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) ' E R R O R : Open boundary segment ', npckgn(ib) - IF(lwp) WRITE(numout,*) ' ========== does not end on land' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - 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_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 - IF(lwp) WRITE(numout,*) ' E R R O R : Segments ', ib1, 'and ', ib2 - IF(lwp) WRITE(numout,*) ' ========== have different open bdy schemes' - IF(lwp) WRITE(numout,*) - nstop = nstop + 1 - ENDIF - ! - END SUBROUTINE bdy_ctl_corn - - !!================================================================================= -END MODULE bdyini diff --git a/MY_SRC/diaharm.F90 b/MY_SRC/diaharm.F90 deleted file mode 100644 index 3bb42dc..0000000 --- a/MY_SRC/diaharm.F90 +++ /dev/null @@ -1,848 +0,0 @@ -MODULE diaharm - !!====================================================================== - !! *** MODULE diaharm *** - !! Harmonic analysis of tidal constituents - !!====================================================================== - !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code - !!---------------------------------------------------------------------- -#if defined key_diaharm - !!---------------------------------------------------------------------- - !! 'key_diaharm' - !! - !! NB: 2017-12 : add 3D harmonic analysis of velocities - !! integration of Maria Luneva's development - !! 'key_3Ddiaharm' - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers variables - USE dom_oce ! ocean space and time domain - USE phycst - USE daymod - USE tide_mod - USE sbctide ! Tidal forcing or not - ! -# if defined key_3Ddiaharm - USE zdf_oce -#endif - ! - USE in_out_manager ! I/O units - USE iom ! I/0 library - USE ioipsl ! NetCDF IPSL library - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE timing ! preformance summary - USE wrk_nemo ! working arrays - - IMPLICIT NONE - PRIVATE - - LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .TRUE. - - INTEGER, PARAMETER :: jpincomax = 2.*jpmax_harmo - INTEGER, PARAMETER :: jpdimsparse = jpincomax*300*24 - - ! !!** namelist variables ** - INTEGER :: nit000_han ! First time step used for harmonic analysis - INTEGER :: nitend_han ! Last time step used for harmonic analysis - INTEGER :: nstep_han ! Time step frequency for harmonic analysis - INTEGER :: nb_ana ! Number of harmonics to analyse - - - INTEGER , ALLOCATABLE, DIMENSION(:) :: name - REAL(wp), ALLOCATABLE, DIMENSION(:) :: ana_freq, ut , vt , ft -# if defined key_3Ddiaharm - REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: ana_temp - REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: out_eta , out_u, out_v , out_w , out_dzi -# else - REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ana_temp - REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: out_eta , out_u, out_v -# endif - - INTEGER :: ninco, nsparse - INTEGER , DIMENSION(jpdimsparse) :: njsparse, nisparse - INTEGER , SAVE, DIMENSION(jpincomax) :: ipos1 - REAL(wp), DIMENSION(jpdimsparse) :: valuesparse - REAL(wp), DIMENSION(jpincomax) :: ztmp4 , ztmp7 - REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) :: ztmp3 , zpilier - REAL(wp), SAVE, DIMENSION(jpincomax) :: zpivot - - CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) - - PUBLIC dia_harm ! routine called by step.F90 - - !!---------------------------------------------------------------------- - !! NEMO/OPA 3.5 , NEMO Consortium (2013) - !! $Id: diaharm.F90 5585 2015-07-10 14:19:11Z jchanut $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE dia_harm_init - !!---------------------------------------------------------------------- - !! *** ROUTINE dia_harm_init *** - !! - !! ** Purpose : Initialization of tidal harmonic analysis - !! - !! ** Method : Initialize frequency array and nodal factor for nit000_han - !! - !!-------------------------------------------------------------------- - INTEGER :: jh, nhan, jl - INTEGER :: ios ! Local integer output status for namelist read - - NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname - !!---------------------------------------------------------------------- - - IF(lwp) THEN - WRITE(numout,*) - WRITE(numout,*) 'dia_harm_init: Tidal harmonic analysis initialization' -# if defined key_3Ddiaharm - WRITE(numout,*) ' - 3D harmonic analysis of currents actovated (key_3Ddiaharm)' -#endif - WRITE(numout,*) '~~~~~~~ ' - ENDIF - ! - IF( .NOT. ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') - ! - CALL tide_init_Wave - ! - REWIND( numnam_ref ) ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis - READ ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist', lwp ) - - REWIND( numnam_cfg ) ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis - READ ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist', lwp ) - IF(lwm) WRITE ( numond, nam_diaharm ) - ! - IF(lwp) THEN - WRITE(numout,*) 'First time step used for analysis: nit000_han= ', nit000_han - WRITE(numout,*) 'Last time step used for analysis: nitend_han= ', nitend_han - WRITE(numout,*) 'Time step frequency for harmonic analysis: nstep_han= ', nstep_han - ENDIF - - ! Basic checks on harmonic analysis time window: - ! ---------------------------------------------- - IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & - & ' restart capability not implemented' ) - IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & - & 'restart capability not implemented' ) - - IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & - & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) - - nb_ana = 0 - DO jh=1,jpmax_harmo - DO jl=1,jpmax_harmo - IF(TRIM(tname(jh)) == Wave(jl)%cname_tide) THEN - nb_ana=nb_ana+1 - ENDIF - END DO - END DO - ! - IF(lwp) THEN - WRITE(numout,*) ' Namelist nam_diaharm' - WRITE(numout,*) ' nb_ana = ', nb_ana - CALL flush(numout) - ENDIF - ! - IF (nb_ana > jpmax_harmo) THEN - IF(lwp) WRITE(numout,*) ' E R R O R dia_harm_init : nb_ana must be lower than jpmax_harmo, stop' - IF(lwp) WRITE(numout,*) ' jpmax_harmo= ', jpmax_harmo - nstop = nstop + 1 - ENDIF - - ALLOCATE(name (nb_ana)) - DO jh=1,nb_ana - DO jl=1,jpmax_harmo - IF (TRIM(tname(jh)) .eq. Wave(jl)%cname_tide) THEN - name(jh) = jl - EXIT - END IF - END DO - END DO - - ! Initialize frequency array: - ! --------------------------- - ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) - - CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) - - IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' - - DO jh = 1, nb_ana - IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh) - END DO - - ! Initialize temporary arrays: - ! ---------------------------- -# if defined key_3Ddiaharm - ALLOCATE( ana_temp( jpi, jpj, 2*nb_ana, 5, jpk ) ) - ana_temp(:,:,:,:,:) = 0._wp -# else - ALLOCATE( ana_temp( jpi, jpj, 2*nb_ana, 3 ) ) - ana_temp(:,:,:,: ) = 0._wp -#endif - - END SUBROUTINE dia_harm_init - - - SUBROUTINE dia_harm ( kt ) - !!---------------------------------------------------------------------- - !! *** ROUTINE dia_harm *** - !! - !! ** Purpose : Tidal harmonic analysis main routine - !! - !! ** Action : Sums ssh/u/v over time analysis [nit000_han,nitend_han] - !! - !!-------------------------------------------------------------------- - INTEGER, INTENT( IN ) :: kt - ! - INTEGER :: ji, jj, jh, jc, nhc -# if defined key_3Ddiaharm - INTEGER :: jk -# endif - REAL(wp) :: ztime, ztemp - !!-------------------------------------------------------------------- - IF( nn_timing == 1 ) CALL timing_start('dia_harm') - - IF( kt == nit000 ) CALL dia_harm_init - - IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN - - ztime = (kt-nit000+1) * rdt - - !IF(lwp) WRITE(numout,*) "ztime OLD", kt, ztime, sshn(25,25) - - nhc = 0 - DO jh = 1, nb_ana - DO jc = 1, 2 - nhc = nhc+1 - ztemp =( MOD(jc,2) * ft(jh) *COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & - & +(1.-MOD(jc,2))* ft(jh) *SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh))) - -! ssh, ub, vb are stored at the last level of 5d array - DO jj = 1,jpj - DO ji = 1,jpi - ! Elevation and currents -# if defined key_3Ddiaharm - ana_temp(ji,jj,nhc,1,jpk) = ana_temp(ji,jj,nhc,1,jpk) + ztemp*sshn(ji,jj)*ssmask (ji,jj) - ana_temp(ji,jj,nhc,2,jpk) = ana_temp(ji,jj,nhc,2,jpk) + ztemp*un_b(ji,jj)*ssumask(ji,jj) - ana_temp(ji,jj,nhc,3,jpk) = ana_temp(ji,jj,nhc,3,jpk) + ztemp*vn_b(ji,jj)*ssvmask(ji,jj) - - ana_temp(ji,jj,nhc,5,jpk) = ana_temp(ji,jj,nhc,5,jpk) & - & + ztemp*bfrva(ji,jj)*vn(ji,jj,mbkv(ji,jj))*ssvmask(ji,jj) - ana_temp(ji,jj,nhc,4,jpk) = ana_temp(ji,jj,nhc,4,jpk) & - & + ztemp*bfrua(ji,jj)*un(ji,jj,mbku(ji,jj))*ssumask(ji,jj) -# else - ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp*sshn(ji,jj)*ssmask (ji,jj) - ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp*un_b(ji,jj)*ssumask(ji,jj) - ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp*vn_b(ji,jj)*ssvmask(ji,jj) -# endif - END DO - END DO - ! -# if defined key_3Ddiaharm -! 3d velocity and density: - DO jk=1,jpk-1 - DO jj = 1,jpj - DO ji = 1,jpi - ! density and velocity - ana_temp(ji,jj,nhc,1,jk) = ana_temp(ji,jj,nhc,1,jk) + ztemp*rhd(ji,jj,jk) - ana_temp(ji,jj,nhc,2,jk) = ana_temp(ji,jj,nhc,2,jk) + ztemp*(un(ji,jj,jk)-un_b(ji,jj)) & - & *umask(ji,jj,jk) - ana_temp(ji,jj,nhc,3,jk) = ana_temp(ji,jj,nhc,3,jk) + ztemp*(vn(ji,jj,jk)-vn_b(ji,jj)) & - & *vmask(ji,jj,jk) - ana_temp(ji,jj,nhc,4,jk) = ana_temp(ji,jj,nhc,4,jk) + ztemp*wn(ji,jj,jk) - - ana_temp(ji,jj,nhc,5,jk) = ana_temp(ji,jj,nhc,5,jk) - 0.5*grav*ztemp*(rhd(ji,jj,jk)+rhd(ji,jj,jk+1) )/max(rn2(ji,jj,jk),1.e-8_wp) -! IF(jk<=mbathy(ji,jj) ) ana_temp(ji,jj,nhc,5,jk) = ana_temp(ji,jj,nhc,5,jk) - & -! & 0.5*grav*ztemp*(rhd(ji,jj,jk)+rhd(ji,jj,jk+1) )/max(rn2(ji,jj,jk),1.e-8_wp) - END DO - END DO - ENDDO -# endif - - END DO - END DO - ! - END IF - - IF ( kt == nitend_han ) CALL dia_harm_end - - IF( nn_timing == 1 ) CALL timing_stop('dia_harm') - - END SUBROUTINE dia_harm - - - SUBROUTINE dia_harm_end - !!---------------------------------------------------------------------- - !! *** ROUTINE diaharm_end *** - !! - !! ** Purpose : Compute the Real and Imaginary part of tidal constituents - !! - !! ** Action : Decompose the signal on the harmonic constituents - !! - !!-------------------------------------------------------------------- - INTEGER :: ji, jj, jh, jc, jn, nhan, jl -# if defined key_3Ddiaharm - INTEGER :: jk -# endif - INTEGER :: ksp, kun, keq - REAL(wp) :: ztime, ztime_ini, ztime_end - REAL(wp) :: X1,X2 - REAL(wp), POINTER, DIMENSION(:,:,:,:) :: ana_amp - !!-------------------------------------------------------------------- - CALL wrk_alloc( jpi , jpj , jpmax_harmo , 2 , ana_amp ) - - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'anharmo_end: kt=nitend_han: Perform harmonic analysis' - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' - - ztime_ini = nit000_han*rdt ! Initial time in seconds at the beginning of analysis - ztime_end = nitend_han*rdt ! Final time in seconds at the end of analysis - nhan = (nitend_han-nit000_han+1)/nstep_han ! Number of dumps used for analysis - -# if defined key_3Ddiaharm - ALLOCATE( out_eta(jpi,jpj,jpk,2*nb_ana), & - & out_u (jpi,jpj,jpk,2*nb_ana), & - & out_v (jpi,jpj,jpk,2*nb_ana), & - & out_w (jpi,jpj,jpk,2*nb_ana), & - & out_dzi(jpi,jpj,jpk,2*nb_ana) ) -# else - ALLOCATE( out_eta(jpi,jpj,2*nb_ana), & - & out_u (jpi,jpj,2*nb_ana), & - & out_v (jpi,jpj,2*nb_ana) ) -# endif - - IF(lwp) WRITE(numout,*) 'ANA F OLD', ft - IF(lwp) WRITE(numout,*) 'ANA U OLD', ut - IF(lwp) WRITE(numout,*) 'ANA V OLD', vt - - - ninco = 2*nb_ana - ksp = 0 - keq = 0 - DO jn = 1, nhan - ztime=( (nhan-jn)*ztime_ini + (jn-1)*ztime_end )/FLOAT(nhan-1) - keq = keq + 1 - kun = 0 - DO jh = 1, nb_ana - DO jc = 1, 2 - kun = kun + 1 - ksp = ksp + 1 - nisparse(ksp) = keq - njsparse(ksp) = kun - valuesparse(ksp) = ( MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & - & + (1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh)) ) - END DO - END DO - END DO - - nsparse = ksp - - ! Density and Elevation: -# if defined key_3Ddiaharm - DO jk=1,jpk -# endif - DO jj = 1, jpj - DO ji = 1, jpi - ! Fill input array - kun = 0 - DO jh = 1, nb_ana - DO jc = 1, 2 - kun = kun + 1 -# if defined key_3Ddiaharm - ztmp4(kun)=ana_temp(ji,jj,kun,1,jk) -# else - ztmp4(kun)=ana_temp(ji,jj,kun,1) -# endif - END DO - END DO - - CALL SUR_DETERMINE(jj) - - ! Fill output array - DO jh = 1, nb_ana - ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1) - ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2) - END DO - END DO - END DO - - - DO jj = 1, jpj - DO ji = 1, jpi - DO jh = 1, nb_ana - X1 = ana_amp(ji,jj,jh,1) - X2 =-ana_amp(ji,jj,jh,2) -# if defined key_3Ddiaharm - out_eta(ji,jj,jk,jh ) = X1 * tmask_i(ji,jj) - out_eta(ji,jj,jk,jh+nb_ana) = X2 * tmask_i(ji,jj) -# else - out_eta(ji,jj ,jh ) = X1 * tmask_i(ji,jj) - out_eta(ji,jj ,jh+nb_ana) = X2 * tmask_i(ji,jj) -# endif - END DO - END DO - END DO - - ! u-component of velocity - DO jj = 1, jpj - DO ji = 1, jpi - ! Fill input array - kun=0 - DO jh = 1,nb_ana - DO jc = 1,2 - kun = kun + 1 -# if defined key_3Ddiaharm - ztmp4(kun)=ana_temp(ji,jj,kun,2,jk) -# else - ztmp4(kun)=ana_temp(ji,jj,kun,2) -# endif - END DO - END DO - - CALL SUR_DETERMINE(jj+1) - - ! Fill output array - DO jh = 1, nb_ana - ana_amp(ji,jj,jh,1) = ztmp7((jh-1)*2+1) - ana_amp(ji,jj,jh,2) = ztmp7((jh-1)*2+2) - END DO - - END DO - END DO - - DO jj = 1, jpj - DO ji = 1, jpi - DO jh = 1, nb_ana - X1= ana_amp(ji,jj,jh,1) - X2=-ana_amp(ji,jj,jh,2) -# if defined key_3Ddiaharm - out_u(ji,jj,jk, jh) = X1 * ssumask(ji,jj) - out_u(ji,jj,jk,nb_ana+jh) = X2 * ssumask(ji,jj) -# else - out_u(ji,jj, jh) = X1 * ssumask(ji,jj) - out_u(ji,jj, nb_ana+jh) = X2 * ssumask(ji,jj) -# endif - ENDDO - ENDDO - ENDDO - - ! v- velocity - DO jj = 1, jpj - DO ji = 1, jpi - ! Fill input array - kun=0 - DO jh = 1,nb_ana - DO jc = 1,2 - kun = kun + 1 -# if defined key_3Ddiaharm - ztmp4(kun)=ana_temp(ji,jj,kun,3,jk) -# else - ztmp4(kun)=ana_temp(ji,jj,kun,3) -# endif - END DO - END DO - - CALL SUR_DETERMINE(jj+1) - - ! Fill output array - DO jh = 1, nb_ana - ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1) - ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2) - END DO - - END DO - END DO - - DO jj = 1, jpj - DO ji = 1, jpi - DO jh = 1, nb_ana - X1=ana_amp(ji,jj,jh,1) - X2=-ana_amp(ji,jj,jh,2) -# if defined key_3Ddiaharm - out_v(ji,jj,jk, jh)=X1 * ssvmask(ji,jj) - out_v(ji,jj,jk,nb_ana+jh)=X2 * ssvmask(ji,jj) -# else - out_v(ji,jj, jh)=X1 * ssvmask(ji,jj) - out_v(ji,jj, nb_ana+jh)=X2 * ssvmask(ji,jj) -# endif - END DO - END DO - END DO - -# if defined key_3Ddiaharm - ! w- velocity - DO jj = 1, jpj - DO ji = 1, jpi - ! Fill input array - kun=0 - DO jh = 1,nb_ana - DO jc = 1,2 - kun = kun + 1 - ztmp4(kun)=ana_temp(ji,jj,kun,4,jk) - END DO - END DO - - CALL SUR_DETERMINE(jj+1) - - ! Fill output array - DO jh = 1, nb_ana - ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1) - ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2) - END DO - - END DO - END DO - - DO jj = 1, jpj - DO ji = 1, jpi - DO jh = 1, nb_ana - X1=ana_amp(ji,jj,jh,1) - X2=-ana_amp(ji,jj,jh,2) - out_w(ji,jj,jk, jh)=X1 * tmask_i(ji,jj) - out_w(ji,jj,jk,nb_ana+jh)=X2 * tmask_i(ji,jj) - END DO - END DO - END DO - - ! dzi- isopycnal displacements - DO jj = 1, jpj - DO ji = 1, jpi - ! Fill input array - kun=0 - DO jh = 1,nb_ana - DO jc = 1,2 - kun = kun + 1 - ztmp4(kun)=ana_temp(ji,jj,kun,5,jk) - END DO - END DO - - CALL SUR_DETERMINE(jj+1) - - ! Fill output array - DO jh = 1, nb_ana - ana_amp(ji,jj,jh,1)=ztmp7((jh-1)*2+1) - ana_amp(ji,jj,jh,2)=ztmp7((jh-1)*2+2) - END DO - - END DO - END DO - - DO jj = 1, jpj - DO ji = 1, jpi - DO jh = 1, nb_ana - X1=ana_amp(ji,jj,jh,1) - X2=-ana_amp(ji,jj,jh,2) - out_dzi(ji,jj,jk, jh)=X1 * tmask_i(ji,jj) - out_dzi(ji,jj,jk,nb_ana+jh)=X2 * tmask_i(ji,jj) - END DO - END DO - END DO - - ENDDO ! jk -# endif - - CALL dia_wri_harm ! Write results in files - CALL wrk_dealloc( jpi , jpj , jpmax_harmo , 2 , ana_amp ) - ! - END SUBROUTINE dia_harm_end - - - SUBROUTINE dia_wri_harm - !!-------------------------------------------------------------------- - !! *** ROUTINE dia_wri_harm *** - !! - !! ** Purpose : Write tidal harmonic analysis results in a netcdf file - !!-------------------------------------------------------------------- - CHARACTER(LEN=lc) :: cltext - CHARACTER(LEN=lc) :: & - cdfile_name_T , & ! name of the file created (T-points) - cdfile_name_U , & ! name of the file created (U-points) - cdfile_name_V ! name of the file created (V-points) - INTEGER :: jh - -# if defined key_3Ddiaharm - CHARACTER(LEN=lc) :: cdfile_name_W ! name of the file created (W-points) - INTEGER :: jk - REAL(WP), ALLOCATABLE, DIMENSION (:,:,:) :: z3real, z3im - REAL(WP), ALLOCATABLE, DIMENSION (:,:) :: z2real, z2im -# endif -!!---------------------------------------------------------------------- - -#if defined key_dimgout - cdfile_name_T = TRIM(cexper)//'_Tidal_harmonics_gridT.dimgproc' - cdfile_name_U = TRIM(cexper)//'_Tidal_harmonics_gridU.dimgproc' - cdfile_name_V = TRIM(cexper)//'_Tidal_harmonics_gridV.dimgproc' -# if defined key_3Ddiaharm - cdfile_name_W = TRIM(cexper)//'_Tidal_harmonics_gridW.dimgproc' -# endif -#endif - - IF(lwp) WRITE(numout,*) ' ' - IF(lwp) WRITE(numout,*) 'dia_wri_harm : Write harmonic analysis results' -#if defined key_dimgout - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ Output files: ', TRIM(cdfile_name_T) - IF(lwp) WRITE(numout,*) ' ', TRIM(cdfile_name_U) - IF(lwp) WRITE(numout,*) ' ', TRIM(cdfile_name_V) -# if defined key_3Ddiaharm - IF(lwp) WRITE(numout,*) ' ', TRIM(cdfile_name_W) -# endif -#endif - IF(lwp) WRITE(numout,*) ' ' - -# if defined key_3Ddiaharm - ALLOCATE( z3real(jpi,jpj,jpk),z3im(jpi,jpj,jpk),z2real(jpi,jpj),z2im(jpi,jpj)) -# endif - - ! A) density and elevation - !///////////// - ! -#if defined key_dimgout - cltext='density amplitude and phase; elevation is level=jpk ' - CALL dia_wri_dimg(TRIM(cdfile_name_T), TRIM(cltext), out_eta, 2*nb_ana, '2') -#else -# if defined key_3Ddiaharm - z3real(:,:,:) = 0._wp; z3im(:,:,:) = 0._wp -# endif - DO jh = 1, nb_ana -# if defined key_3Ddiaharm - DO jk=1,jpkm1 - z3real(:,:,jk)=out_eta(:,:,jk,jh) - z3im (:,:,jk)=out_eta(:,:,jk,jh+nb_ana) - ENDDO - z2real(:,:)=out_eta(:,:,jpk,jh); z2im(:,:)=out_eta(:,:,jpk,jh+nb_ana) - CALL iom_put( TRIM(tname(jh))//'x_ro', z3real(:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_ro', z3im (:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'x' , z2real(:,: ) ) - CALL iom_put( TRIM(tname(jh))//'y' , z2im (:,: ) ) -# else - WRITE(numout,*) "OUTPUT ORI: ", TRIM(tname(jh))//'x', ' & ', TRIM(tname(jh))//'y', MAXVAL(out_eta(:,:,jh)) - CALL iom_put( TRIM(tname(jh))//'x', out_eta(:,:,jh) ) - CALL iom_put( TRIM(tname(jh))//'y', out_eta(:,:,nb_ana+jh) ) -# endif - END DO -#endif - - ! B) u - !///////// - ! -#if defined key_dimgout - cltext='3d u amplitude and phase; ubar is the last level' - CALL dia_wri_dimg(TRIM(cdfile_name_U), TRIM(cltext), out_u, 2*nb_ana, '2') -#else -# if defined key_3Ddiaharm - z3real(:,:,:) = 0._wp; z3im(:,:,:) = 0._wp -# endif - DO jh = 1, nb_ana -# if defined key_3Ddiaharm - DO jk=1,jpkm1 - z3real(:,:,jk)=out_u(:,:,jk,jh) - z3im (:,:,jk)=out_u(:,:,jk,jh+nb_ana) - ENDDO - z2real(:,:)=out_u(:,:,jpk,jh); z2im(:,:)=out_u(:,:,jpk,jh+nb_ana) - CALL iom_put( TRIM(tname(jh))//'x_u3d', z3real(:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_u3d', z3im (:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'x_u2d', z2real(:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_u2d', z2im (:,:) ) - z2real(:,:)=out_w(:,:,jpk,jh); z2im(:,:)=out_w(:,:,jpk,jh+nb_ana) - CALL iom_put( TRIM(tname(jh))//'x_tabx', z2real(:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_tabx', z2im (:,:) ) -# else - CALL iom_put( TRIM(tname(jh))//'x_u2d', out_u(:,:,jh) ) - CALL iom_put( TRIM(tname(jh))//'y_u2d', out_u(:,:,nb_ana+jh) ) -# endif - END DO -#endif - - ! C) v - !///////// - ! -#if defined key_dimgout - cltext='3d v amplitude and phase; vbar is the last level' - CALL dia_wri_dimg(TRIM(cdfile_name_V), TRIM(cltext), out_v, 2*nb_ana, '2') -#else -# if defined key_3Ddiaharm - z3real(:,:,:) = 0._wp; z3im(:,:,:) = 0._wp -# endif - DO jh = 1, nb_ana -# if defined key_3Ddiaharm - DO jk=1,jpkm1 - z3real(:,:,jk)=out_v(:,:,jk,jh) - z3im (:,:,jk)=out_v(:,:,jk,jh+nb_ana) - ENDDO - z2real(:,:)=out_v(:,:,jpk,jh); z2im(:,:)=out_v(:,:,jpk,jh+nb_ana) - CALL iom_put( TRIM(tname(jh))//'x_v3d', z3real(:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_v3d', z3im (:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'x_v2d' , z2real(:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_v2d' , z2im (:,:) ) - z2real(:,:)=out_dzi(:,:,jpk,jh); z2im(:,:)=out_dzi(:,:,jpk,jh+nb_ana) - CALL iom_put( TRIM(tname(jh))//'x_taby', z2real(:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_taby', z2im (:,:) ) -# else - CALL iom_put( TRIM(tname(jh))//'x_v2d', out_v(:,:,jh ) ) - CALL iom_put( TRIM(tname(jh))//'y_v2d', out_v(:,:,jh+nb_ana) ) -# endif - END DO - -#endif - ! D) w -# if defined key_3Ddiaharm -# if defined key_dimgout - cltext='3d w amplitude and phase; vort_baro is the last level' - CALL dia_wri_dimg(TRIM(cdfile_name_W), TRIM(cltext), out_w, 2*nb_ana, '2') -# else - DO jh = 1, nb_ana - DO jk=1,jpkm1 - z3real(:,:,jk)=out_w(:,:,jk,jh) - z3im(:,:,jk)=out_w(:,:,jk,jh+nb_ana) - ENDDO - CALL iom_put( TRIM(tname(jh))//'x_w3d', z3real(:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_w3d', z3im(:,:,:) ) - END DO -# endif - -! E) dzi + tau_bot -# if defined key_dimgout - cltext='dzi=g*ro/N2 amplitude and phase' - CALL dia_wri_dimg(TRIM(cdfile_name_W), TRIM(cltext), out_w, 2*nb_ana, '2') -# else - DO jh = 1, nb_ana - DO jk=1,jpkm1 - z3real(:,:,jk)=out_dzi(:,:,jk,jh) - z3im(:,:,jk)=out_dzi(:,:,jk,jh+nb_ana) - ENDDO - CALL iom_put( TRIM(tname(jh))//'x_dzi', z3real(:,:,:) ) - CALL iom_put( TRIM(tname(jh))//'y_dzi', z3im(:,:,:) ) - END DO -# endif -# endif - - ! -# if defined key_3Ddiaharm - DEALLOCATE(z3real, z3im, z2real,z2im) -# endif - - END SUBROUTINE dia_wri_harm - - - SUBROUTINE SUR_DETERMINE(init) - !!--------------------------------------------------------------------------------- - !! *** ROUTINE SUR_DETERMINE *** - !! - !! - !! - !!--------------------------------------------------------------------------------- - INTEGER, INTENT(in) :: init - ! - INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jk1_sd, jk2_sd - REAL(wp) :: zval1, zval2, zx1 - REAL(wp), POINTER, DIMENSION(:) :: ztmpx, zcol1, zcol2 - INTEGER , POINTER, DIMENSION(:) :: ipos2, ipivot - !--------------------------------------------------------------------------------- - CALL wrk_alloc( jpincomax , ztmpx , zcol1 , zcol2 ) - CALL wrk_alloc( jpincomax , ipos2 , ipivot ) - - IF( init == 1 ) THEN - IF( nsparse > jpdimsparse ) CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') - IF( ninco > jpincomax ) CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') - ! - ztmp3(:,:) = 0._wp - ! - DO jk1_sd = 1, nsparse - DO jk2_sd = 1, nsparse - nisparse(jk2_sd) = nisparse(jk2_sd) - njsparse(jk2_sd) = njsparse(jk2_sd) - IF( nisparse(jk2_sd) == nisparse(jk1_sd) ) THEN - ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) & - & + valuesparse(jk1_sd)*valuesparse(jk2_sd) - ENDIF - END DO - END DO - ! - DO jj_sd = 1 ,ninco - ipos1(jj_sd) = jj_sd - ipos2(jj_sd) = jj_sd - END DO - ! - DO ji_sd = 1 , ninco - ! - !find greatest non-zero pivot: - zval1 = ABS(ztmp3(ji_sd,ji_sd)) - ! - ipivot(ji_sd) = ji_sd - DO jj_sd = ji_sd, ninco - zval2 = ABS(ztmp3(ji_sd,jj_sd)) - IF( zval2.GE.zval1 )THEN - ipivot(ji_sd) = jj_sd - zval1 = zval2 - ENDIF - END DO - ! - DO ji1_sd = 1, ninco - zcol1(ji1_sd) = ztmp3(ji1_sd,ji_sd) - zcol2(ji1_sd) = ztmp3(ji1_sd,ipivot(ji_sd)) - ztmp3(ji1_sd,ji_sd) = zcol2(ji1_sd) - ztmp3(ji1_sd,ipivot(ji_sd)) = zcol1(ji1_sd) - END DO - ! - ipos2(ji_sd) = ipos1(ipivot(ji_sd)) - ipos2(ipivot(ji_sd)) = ipos1(ji_sd) - ipos1(ji_sd) = ipos2(ji_sd) - ipos1(ipivot(ji_sd)) = ipos2(ipivot(ji_sd)) - zpivot(ji_sd) = ztmp3(ji_sd,ji_sd) - DO jj_sd = 1, ninco - ztmp3(ji_sd,jj_sd) = ztmp3(ji_sd,jj_sd) / zpivot(ji_sd) - END DO - ! - DO ji2_sd = ji_sd+1, ninco - zpilier(ji2_sd,ji_sd)=ztmp3(ji2_sd,ji_sd) - DO jj_sd=1,ninco - ztmp3(ji2_sd,jj_sd)= ztmp3(ji2_sd,jj_sd) - ztmp3(ji_sd,jj_sd) * zpilier(ji2_sd,ji_sd) - END DO - END DO - ! - END DO - ! - ENDIF ! End init==1 - - DO ji_sd = 1, ninco - ztmp4(ji_sd) = ztmp4(ji_sd) / zpivot(ji_sd) - DO ji2_sd = ji_sd+1, ninco - ztmp4(ji2_sd) = ztmp4(ji2_sd) - ztmp4(ji_sd) * zpilier(ji2_sd,ji_sd) - END DO - END DO - - !system solving: - ztmpx(ninco) = ztmp4(ninco) / ztmp3(ninco,ninco) - ji_sd = ninco - DO ji_sd = ninco-1, 1, -1 - zx1 = 0._wp - DO jj_sd = ji_sd+1, ninco - zx1 = zx1 + ztmpx(jj_sd) * ztmp3(ji_sd,jj_sd) - END DO - ztmpx(ji_sd) = ztmp4(ji_sd)-zx1 - END DO - - DO jj_sd =1, ninco - ztmp7(ipos1(jj_sd))=ztmpx(jj_sd) - END DO - - CALL wrk_dealloc( jpincomax , ztmpx , zcol1 , zcol2 ) - CALL wrk_dealloc( jpincomax , ipos2 , ipivot ) - ! - END SUBROUTINE SUR_DETERMINE - -#else - !!---------------------------------------------------------------------- - !! Default case : Empty module - !!---------------------------------------------------------------------- - LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .FALSE. -CONTAINS - SUBROUTINE dia_harm ( kt ) ! Empty routine - INTEGER, INTENT( IN ) :: kt - WRITE(*,*) 'dia_harm: you should not have seen this print' - END SUBROUTINE dia_harm -#endif - - !!====================================================================== -END MODULE diaharm diff --git a/MY_SRC/diaharm_fast.F90 b/MY_SRC/diaharm_fast.F90 deleted file mode 100644 index 66ba75e..0000000 --- a/MY_SRC/diaharm_fast.F90 +++ /dev/null @@ -1,857 +0,0 @@ -MODULE diaharm_fast - !!====================================================================== - !! *** MODULE example *** - !! Ocean physics: On line harmonic analyser - !! - !!===================================================================== - -#if defined key_diaharm_fast - - !!---------------------------------------------------------------------- - !! 'key_harm_ana' : Calculate harmonic analysis - !!---------------------------------------------------------------------- - !! harm_ana : - !! harm_ana_init : - !! NB: 2017-12 : add 3D harmonic analysis of velocities - !! integration of Maria Luneva's development - !! 'key_3Ddiaharm' - !!---------------------------------------------------------------------- - - USE oce ! ocean dynamics and tracers - USE dom_oce ! ocean space and time domain - USE iom - USE in_out_manager ! I/O units - USE phycst ! physical constants - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE bdy_oce ! ocean open boundary conditions - USE bdytides ! tidal bdy forcing - USE daymod ! calendar - USE tideini - USE restart - USE ioipsl, ONLY : ju2ymds ! for calendar - ! - ! - USE timing ! preformance summary - USE zdf_oce - - IMPLICIT NONE - PRIVATE - - !! * Routine accessibility - PUBLIC dia_harm_fast ! routine called in step.F90 module - LOGICAL, PUBLIC, PARAMETER :: lk_diaharm_fast = .TRUE. ! to be run or not - LOGICAL, PUBLIC :: lk_diaharm_2D ! = .TRUE. ! to run 2d - LOGICAL, PUBLIC :: lk_diaharm_3D ! = .TRUE. ! to run 3d - - !! * Module variables - INTEGER, PARAMETER :: nharm_max = jpmax_harmo ! max number of harmonics to be analysed - INTEGER, PARAMETER :: nhm_max = 2*nharm_max+1 - INTEGER, PARAMETER :: nvab = 2 ! number of 3D variables - INTEGER :: nharm - INTEGER :: nhm - INTEGER :: & !!! ** toto namelist (namtoto) ** - nflag = 1 ! default value of nflag - REAL(wp), DIMENSION(nharm_max) :: & - om_tide ! tidal frequencies ( rads/sec) - REAL(wp), ALLOCATABLE,SAVE,DIMENSION(:) :: & - bzz,c,x ! work arrays - REAL(wp) :: cca,ssa,zm,bt,dd_cumul -! - REAL(wp), PUBLIC :: fjulday_startharm !: Julian Day since start of harmonic analysis - REAL(wp), PUBLIC, ALLOCATABLE,DIMENSION(:) :: anau, anav, anaf ! nodel/phase corrections used by diaharmana - REAL(WP), ALLOCATABLE,SAVE,DIMENSION(:,:) :: cc,a -! - INTEGER :: nvar_2d, nvar_3d !: number of 2d and 3d variables to analyse - INTEGER, ALLOCATABLE,DIMENSION(:) :: m_posi_2d, m_posi_3d - -! Name of variables used in the restart - CHARACTER( LEN = 10 ), DIMENSION(5), PARAMETER :: m_varName2d = (/'ssh','u2d','v2d','ubfr','vbfr'/) - CHARACTER( LEN = 10 ), DIMENSION(4), PARAMETER :: m_varName3d = (/'rho','u3d','v3d','w3d'/) -! - REAL(wp), ALLOCATABLE,SAVE,DIMENSION(:,:,:,: ) :: g_cosamp2D, g_sinamp2D, g_cumul_var2D - REAL(wp), ALLOCATABLE,SAVE,DIMENSION(:,:,:,:,:) :: g_cosamp3D, g_sinamp3D, g_cumul_var3D -! - REAL(wp), ALLOCATABLE,SAVE,DIMENSION(:,:) :: g_out2D,h_out2D ! arrays for output - REAL(wp), ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: g_out3D,h_out3D ! arrays for 3D output -! -! NAMELIST - LOGICAL, PUBLIC :: ln_diaharm_store !: =T Stores data for harmonic Analysis - LOGICAL, PUBLIC :: ln_diaharm_compute !: =T Compute harmonic Analysis - LOGICAL, PUBLIC :: ln_diaharm_read_restart !: =T Read restart from a previous run - LOGICAL, PUBLIC :: ln_ana_ssh, ln_ana_uvbar, ln_ana_bfric, ln_ana_rho, ln_ana_uv3d, ln_ana_w3d - INTEGER :: nb_ana ! Number of harmonics to analyse - CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) - INTEGER , ALLOCATABLE, DIMENSION(:) :: ntide_all ! INDEX within the full set of constituents (tide.h90) - INTEGER , ALLOCATABLE, DIMENSION(:) :: ntide_sub ! INDEX within the subset of constituents pass in input - - !! * Substitutions - - !!---------------------------------------------------------------------- - !! OPA 9.0 , LOCEAN-IPSL (2005) - !! or LIM 2.0 , UCL-LOCEAN-IPSL (2005) - !! or TOP 1.0 , LOCEAN-IPSL (2005) - !! $Header: /home/opalod/NEMOCVSROOT/NEMO/OPA_SRC/module_example,v 1.3 2005/03/27 18:34:47 opalod Exp $ - !! This software is governed by the CeCILL licence see modipsl/doc/NEMO_CeCILL.txt - !!---------------------------------------------------------------------- - -CONTAINS - - SUBROUTINE dia_harm_fast( kt ) - !!---------------------------------------------------------------------- - !! *** ROUTINE harm_ana *** - !! - !! ** Purpose : Harmonic analyser - !! - !! ** Method : - !! - !! ** Action : - first action (share memory array/varible modified - !! in this routine - !! - second action ..... - !! - ..... - !! - !! References : - !! Give references if exist otherwise suppress these lines - !! - !! History : - !! 9.0 ! 03-08 (Autor Names) Original code - !! ! 02-08 (Author names) brief description of modifications - !!---------------------------------------------------------------------- - !! * Modules used - - !! * arguments - INTEGER, INTENT( in ) :: & - kt ! describe it!!! - - !! * local declarations - INTEGER :: ji, jk, jj ! dummy loop arguments - INTEGER :: jh, i1, i2, jgrid - INTEGER :: j2d, j3d - REAL(WP) :: sec2start - !!-------------------------------------------------------------------- - - IF( nn_timing == 1 ) CALL timing_start( 'dia_harm_fast' ) - IF( kt == nit000 ) CALL harm_ana_init ! Initialization (first time-step only) - - IF ( ln_diaharm_store .and. ( lk_diaharm_2D .or. lk_diaharm_3D) ) THEN - - ! this bit done every time step - nhm=2*nb_ana+1 - c(1) = 1.0 - - sec2start = nint( (fjulday-fjulday_startharm)*86400._wp ) - !IF(lwp) WRITE(numout,*) "ztime NEW", kt, sec2start, fjulday_startharm - - DO jh=1,nb_ana - c(2*jh ) = anaf(jh)*cos( sec2start*om_tide(jh) + anau(jh) + anav(jh) ) - c(2*jh+1) = anaf(jh)*sin( sec2start*om_tide(jh) + anau(jh) + anav(jh) ) - ENDDO - - !IF(lwp) WRITE(numout,*) "c init", c, "c end", sec2start, om_tide(1), anau(1), anav(1),"end nodal" - - - ! CUMULATE - DO ji=1,jpi ! loop lon - DO jj=1,jpj ! loop lat - DO jh=1,nhm ! loop harmonic - - DO j2d=1,nvar_2d - IF ( m_posi_2d(j2d) .eq. 1 ) dd_cumul = c(jh) * sshn(ji,jj) * ssmask (ji,jj) ! analysis elevation - IF ( m_posi_2d(j2d) .eq. 2 ) dd_cumul = c(jh) * un_b(ji,jj) * ssumask(ji,jj) ! analysis depth average velocities - IF ( m_posi_2d(j2d) .eq. 3 ) dd_cumul = c(jh) * vn_b(ji,jj) * ssvmask(ji,jj) - IF ( m_posi_2d(j2d) .eq. 4 ) dd_cumul = c(jh) * bfrua(ji,jj) * un(ji,jj,mbku(ji,jj)) * ssumask(ji,jj) ! analysis bottom friction - IF ( m_posi_2d(j2d) .eq. 5 ) dd_cumul = c(jh) * bfrva(ji,jj) * vn(ji,jj,mbkv(ji,jj)) * ssvmask(ji,jj) - g_cumul_var2D(jh,ji,jj,j2d) = g_cumul_var2D(jh,ji,jj,j2d) + dd_cumul - ENDDO - - DO j3d=1,nvar_3d - DO jk=1,jpkm1 - IF ( m_posi_3d(j3d) .eq. 1 ) dd_cumul = c(jh) * rhd(ji,jj,jk) * tmask(ji,jj,jk) - IF ( m_posi_3d(j3d) .eq. 2 ) dd_cumul = c(jh) * ( un(ji,jj,jk)-un_b(ji,jj) ) * umask(ji,jj,jk) - IF ( m_posi_3d(j3d) .eq. 3 ) dd_cumul = c(jh) * ( vn(ji,jj,jk)-vn_b(ji,jj) ) * vmask(ji,jj,jk) - IF ( m_posi_3d(j3d) .eq. 4 ) dd_cumul = c(jh) * wn(ji,jj,jk) * wmask(ji,jj,jk) - g_cumul_var3D(jh,ji,jj,jk,j3d) = g_cumul_var3D(jh,ji,jj,jk,j3d) + dd_cumul - ENDDO - ENDDO - - ENDDO ! end loop harmonic - ENDDO ! end loop lat - ENDDO ! end loop lon - - ! Compute nodal factor cumulative cross-product - DO i1=1,nhm - DO i2=1,nhm - cc(i1,i2)=cc(i1,i2)+c(i1)*c(i2) - ENDDO - ENDDO - - ! Output RESTART - IF( kt == nitrst ) THEN - CALL harm_rst_write(kt) ! Dump out data for a restarted run - ENDIF - - ! At End of run - IF ( kt == nitend ) THEN - - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'harm_ana : harmonic analysis of tides at end of run' - IF(lwp) WRITE(numout,*) '~~~~~~~~~' - - IF( ln_diaharm_compute ) THEN - - ! INITIALISE TABLE TO 0 - IF ( nvar_2d .gt. 0 ) THEN - g_cosamp2D = 0.0_wp - g_sinamp2D = 0.0_wp - ENDIF - IF ( nvar_3d .gt. 0 ) THEN - g_cosamp3D = 0.0_wp - g_sinamp3D = 0.0_wp - ENDIF - - ! FIRST OUTPUT 2D VARIABLES - DO jgrid=1,nvar_2d ! loop number of 2d variables (ssh, U2d, V2d, UVfric) to analyse harmonically - DO ji=1,jpi ! loop lon - DO jj=1,jpj ! loop lat - bt = 1.0_wp; bzz(:) = 0.0_wp - DO jh=1,nhm ! loop harmonic - bzz(jh) = g_cumul_var2D(jh,ji,jj,jgrid) - bt = bt*bzz(jh) - ENDDO - ! Copy back original cumulated nodal factor - a(:,:) = cc(:,:) -! now do gaussian elimination of the system -! a * x = b -! the matrix x is (a0,a1,b1,a2,b2 ...) -! the matrix a and rhs b solved here for x - x=0.0_wp - IF(bt.ne.0.) THEN - CALL gelim( a, bzz, x, nhm ) -! Backup output in variables - DO jh=1,nb_ana - g_cosamp2D(jh,ji,jj,jgrid) = x(jh*2 ) - g_sinamp2D(jh,ji,jj,jgrid) = x(jh*2+1) - ENDDO - g_cosamp2D( 0,ji,jj,jgrid) = x(1) - g_sinamp2D( 0,ji,jj,jgrid) = 0.0_wp - ENDIF ! bt.ne.0. - ENDDO ! jj - ENDDO ! ji - ENDDO ! jgrid - - ! SECOND OUTPUT 3D VARIABLES - DO jgrid=1,nvar_3d ! loop number of 3d variables rho, U, V, W - DO jk=1,jpkm1 ! loop over vertical level - DO ji=1,jpi ! loop over lon - DO jj=1,jpj ! loop over lat - bt = 1.0_wp; bzz(:) = 0.0_wp - DO jh=1,nhm - bzz(jh) = g_cumul_var3D(jh,ji,jj,jk,jgrid) - bt = bt*bzz(jh) - ENDDO - ! Copy back original cumulated nodal factor - a(:,:) = cc(:,:) -! now do gaussian elimination of the system -! a * x = b -! the matrix x is (a0,a1,b1,a2,b2 ...) -! the matrix a and rhs b solved here for x - x=0.0_wp - IF(bt.ne.0.) THEN - CALL gelim( a, bzz, x, nhm ) -! Backup output in variables - DO jh=1,nb_ana - g_cosamp3D(jh,ji,jj,jk,jgrid) = x(jh*2 ) - g_sinamp3D(jh,ji,jj,jk,jgrid) = x(jh*2+1) - ENDDO - g_cosamp3D ( 0,ji,jj,jk,jgrid) = x(1) - g_sinamp3D ( 0,ji,jj,jk,jgrid) = 0.0_wp - ENDIF ! bt.ne.0. - ENDDO ! jj - ENDDO ! ji - ENDDO ! jk - ENDDO ! jgrid - - CALL harm_ana_out ! output analysis (last time step) - - ELSE ! ln_harmana_compute = False - IF(lwp) WRITE(numout,*) " Skipping Computing harmonics at last step" - - ENDIF ! ln_harmana_compute - ENDIF ! kt == nitend - - ENDIF - - IF( nn_timing == 1 ) CALL timing_stop( 'dia_harm_fast' ) - - END SUBROUTINE dia_harm_fast - - SUBROUTINE harm_ana_init - !!---------------------------------------------------------------------- - !! *** ROUTINE harm_ana_init *** - !! - !! ** Purpose : initialization of .... - !! - !! ** Method : blah blah blah ... - !! - !! ** input : Namlist namexa - !! - !! ** Action : ... - !! - !! history : - !! 9.0 ! 03-08 (Autor Names) Original code - !!---------------------------------------------------------------------- - !! * local declarations - INTEGER :: ji, jk, jh ! dummy loop indices - INTEGER :: ios ! Local integer output status for namelist read - INTEGER :: k2d, k3d ! dummy number of analysis - NAMELIST/nam_diaharm_fast/ ln_diaharm_store, ln_diaharm_compute, ln_diaharm_read_restart, ln_ana_ssh, ln_ana_uvbar, ln_ana_bfric, ln_ana_rho, ln_ana_uv3d, ln_ana_w3d, tname - !!---------------------------------------------------------------------- - - lk_diaharm_2D = .TRUE. ! to run 2d - lk_diaharm_3D = .TRUE. ! to run 3d - - IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'harm_init : initialization of harmonic analysis of tides' - IF(lwp) WRITE(numout,*) '~~~~~~~~~' - - ! GET NAMELIST DETAILS - REWIND( numnam_ref ) ! Namelist nam_diaharm_fast in reference namelist : Tidal harmonic analysis - READ ( numnam_ref, nam_diaharm_fast, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm_fast in reference namelist', lwp ) - - REWIND( numnam_cfg ) ! Namelist nam_diaharm_fast in configuration namelist : Tidal harmonic analysis - READ ( numnam_cfg, nam_diaharm_fast, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm_fast in configuration namelist', lwp ) - IF(lwm) WRITE ( numond, nam_diaharm_fast ) - - ! GET NUMBER OF HARMONIC TO ANALYSE - from diaharm.F90 - nb_ana = 0 - DO jk=1,jpmax_harmo - DO ji=1,nb_harmo - IF(TRIM(tname(jk)) == Wave( ntide(ji) )%cname_tide ) THEN - nb_ana=nb_ana+1 - ENDIF - END DO - END DO - ! - IF(lwp) THEN - WRITE(numout,*) ' Namelist nam_diaharm_fast' - WRITE(numout,*) ' nb_ana = ', nb_ana - CALL flush(numout) - ENDIF - ! - IF (nb_ana > nharm_max) THEN - IF(lwp) WRITE(numout,*) ' E R R O R harm_ana : nb_ana must be lower than nharm_max, stop' - IF(lwp) WRITE(numout,*) ' nharm_max = ', nharm_max - nstop = nstop + 1 - ENDIF - - ALLOCATE(ntide_all(nb_ana)) - ALLOCATE(ntide_sub(nb_ana)) - - DO jk=1,nb_ana - DO ji=1,nb_harmo - IF (TRIM(tname(jk)) .eq. Wave( ntide(ji) )%cname_tide ) THEN - ntide_sub(jk) = ji - ntide_all(jk) = ntide(ji) - EXIT - END IF - END DO - END DO - - ! SEARCH HOW MANY VARIABLES 2D AND 3D TO PROCESS - nvar_2d = 0; nvar_3d = 0 - IF ( ln_ana_ssh ) nvar_2d = nvar_2d + 1 ! analysis elevation - IF ( ln_ana_uvbar ) nvar_2d = nvar_2d + 2 ! analysis depth-averaged velocity - IF ( ln_ana_bfric ) nvar_2d = nvar_2d + 2 ! analysis bottom friction - - IF ( ln_ana_rho ) nvar_3d = nvar_3d + 1 ! analysis density - IF ( ln_ana_uv3d ) nvar_3d = nvar_3d + 2 ! analysis 3D horizontal velocities - IF ( ln_ana_w3d ) nvar_3d = nvar_3d + 1 ! analysis 3D vertical velocity - - ! CHECK IF SOMETHING TO RUN - IF ( nvar_2d .eq. 0 ) lk_diaharm_2D = .FALSE. ! no 2d to run - IF ( nvar_3d .eq. 0 ) lk_diaharm_3D = .FALSE. ! no 3d to run -! IF ( nvar_2d .gt. 0 .and. nvar_3d .gt. 0 ) lk_diaharm_fast = .FALSE. -! IF ( .NOT. ln_diaharm_store ) lk_diaharm_fast = .FALSE. - - IF ( ln_diaharm_store .and. ( lk_diaharm_2D .or. lk_diaharm_3D) ) THEN - - ! DO ALLOCATIONS - IF ( lk_diaharm_2D ) THEN - ALLOCATE( g_cumul_var2D(nb_ana*2+1,jpi,jpj, nvar_2d) ) - ALLOCATE( g_cosamp2D( 0:nb_ana*2+1,jpi,jpj, nvar_2d) ) - ALLOCATE( g_sinamp2D( 0:nb_ana*2+1,jpi,jpj, nvar_2d) ) - ALLOCATE( g_out2D (jpi,jpj) ) - ALLOCATE( h_out2D (jpi,jpj) ) - ALLOCATE( m_posi_2d( nvar_2d ) ); m_posi_2d(:)=0 - ENDIF - - IF ( lk_diaharm_3D ) THEN - ALLOCATE( g_cumul_var3D(nb_ana*2+1,jpi,jpj,jpk,nvar_3d) ) - ALLOCATE( g_cosamp3D( 0:nb_ana*2+1,jpi,jpj,jpk,nvar_3d) ) - ALLOCATE( g_sinamp3D( 0:nb_ana*2+1,jpi,jpj,jpk,nvar_3d) ) - ALLOCATE( g_out3D (jpi,jpj,jpk) ) - ALLOCATE( h_out3D (jpi,jpj,jpk) ) - ALLOCATE( m_posi_3d( nvar_3d ) ); m_posi_3d(:)=0 - ENDIF - - ALLOCATE( cc(nb_ana*2+1,nb_ana*2+1) ) - ALLOCATE( a (nb_ana*2+1,nb_ana*2+1) ) - ALLOCATE( bzz(nb_ana*2+1) ) - ALLOCATE( x (nb_ana*2+1) ) - ALLOCATE( c (nb_ana*2+1) ) - ALLOCATE( anau(nb_ana) ) - ALLOCATE( anav(nb_ana) ) - ALLOCATE( anaf(nb_ana) ) - ! END ALLOCATE - - ! STORE INDEX OF WHAT TO PRODUCE DEPENDING ON ACTIVATED LOGICAL - ! MAKES THINGS EASIER AND FASTER LATER - ! !!! UGLY !!! - jh = 1; k2d = 0; - IF ( ln_ana_ssh ) THEN - k2d = k2d + 1; m_posi_2d(k2d) = jh - IF(lwp) WRITE(numout,*) " - ssh harmonic analysis activated (ln_ana_ssh)" - ENDIF - jh = jh + 1 - IF ( ln_ana_uvbar ) THEN - k2d = k2d + 1; m_posi_2d(k2d) = jh - jh = jh + 1 - k2d = k2d + 1; m_posi_2d(k2d) = jh - IF(lwp) WRITE(numout,*) " - barotropic currents harmonic analysis activated (ln_ana_uvbar)" - ELSE - jh = jh + 1 - ENDIF - jh = jh + 1 - IF ( ln_ana_bfric ) THEN - k2d = k2d + 1; m_posi_2d(k2d) = jh - jh = jh + 1; - k2d = k2d + 1; m_posi_2d(k2d) = jh - IF(lwp) WRITE(numout,*) " - bottom friction harmonic analysis activated (ln_ana_vbfr)" - ELSE - jh = jh + 1 - ENDIF - - ! and for 3D - jh = 1; k3d = 0; - IF ( ln_ana_rho ) THEN - k3d = k3d + 1; m_posi_3d(k3d) = jh - IF(lwp) WRITE(numout,*) " - 3D density harmonic analysis activated (ln_ana_rho)" - ENDIF - jh = jh + 1 - IF ( ln_ana_uv3d ) THEN - k3d = k3d + 1; m_posi_3d(k3d) = jh - jh = jh + 1 - k3d = k3d + 1; m_posi_3d(k3d) = jh - IF(lwp) WRITE(numout,*) " - 3D horizontal currents harmonic analysis activated (ln_ana_uv3d)" - ELSE - jh = jh + 1 - ENDIF - jh = jh + 1 - IF ( ln_ana_w3d ) THEN - k3d = k3d + 1; m_posi_3d(k3d) = jh - IF(lwp) WRITE(numout,*) " - 3D vertical currents harmonic analysis activated (ln_ana_w3d)" - ENDIF - - ! SELECT AND STORE FREQUENCIES - IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' - DO jh=1,nb_ana - om_tide(jh) = omega_tide( ntide_sub(jh) ) - IF(lwp) WRITE(numout,*) ' - ',tname(jh),' ',om_tide(jh) - ENDDO - - ! READ RESTART IF - IF ( ln_diaharm_read_restart ) THEN - IF (lwp) WRITE(numout,*) "Reading previous harmonic data from previous run" - ! Need to read in bssh bz, cc anau anav and anaf - call harm_rst_read ! This reads in from the previous day - ! Currrently the data in in assci format - ELSE - - IF (lwp) WRITE(numout,*) "Starting harmonic analysis from Fresh " - - IF ( lk_diaharm_2D ) g_cumul_var2D(:,:,:,: ) = 0.0_wp - IF ( lk_diaharm_3D ) g_cumul_var3D(:,:,:,:,:) = 0.0_wp - cc = 0.0_wp - a (:,:) = 0.0_wp ! NB - bzz (:) = 0.0_wp - x (:) = 0.0_wp - c (:) = 0.0_wp - anau (:) = 0.0_wp - anav (:) = 0.0_wp - anaf (:) = 0.0_wp - - DO jh = 1, nb_ana - anau(jh) = utide ( ntide_sub(jh) ) - anav(jh) = v0tide( ntide_sub(jh) ) - anaf(jh) = ftide ( ntide_sub(jh) ) - END DO - - fjulday_startharm=fjulday !Set this at very start and store - - IF (lwp) THEN - WRITE(numout,*) '--------------------------' - WRITE(numout,*) ' - Output anaf for check' - WRITE(numout,*) 'ANA F', anaf - WRITE(numout,*) 'ANA U', anau - WRITE(numout,*) 'ANA V', anav - WRITE(numout,*) fjulday_startharm - WRITE(numout,*) '--------------------------' - ENDIF - - ENDIF - - ELSE - - IF (lwp) WRITE(numout,*) "No variable setup for harmonic analysis" - - ENDIF - - END SUBROUTINE harm_ana_init -! - SUBROUTINE gelim (a,b,x,n) - !!---------------------------------------------------------------------- - !! *** ROUTINE harm_ana *** - !! - !! ** Purpose : Guassian elimination - !! - !! - !! ** Action : - first action (share memory array/varible modified - !! in this routine - !! - second action ..... - !! - ..... - !! - !! References : - !! Give references if exist otherwise suppress these lines - !! - !! History : - implicit none -! - integer :: n - REAL(WP) :: b(nb_ana*2+1), a(nb_ana*2+1,nb_ana*2+1) - REAL(WP) :: x(nb_ana*2+1) - INTEGER :: row,col,prow,pivrow,rrow - REAL(WP) :: atemp - REAL(WP) :: pivot - REAL(WP) :: m - - do row=1,n-1 - pivrow=row - pivot=a(row,n-row+1) - do prow=row+1,n - if (abs(a(prow,n-row+1)).gt.abs(pivot) ) then - pivot=a(prow,n-row+1) - pivrow=prow - endif - enddo -! swap row and prow - if ( pivrow .ne. row ) then - atemp=b(pivrow) - b(pivrow)=b(row) - b(row)=atemp - do col=1,n - atemp=a(pivrow,col) - a(pivrow,col)=a(row,col) - a(row,col)=atemp - enddo - endif - - do rrow=row+1,n - if (a(row,row).ne.0) then - - m=-a(rrow,n-row+1)/a(row,n-row+1) - do col=1,n - a(rrow,col)=m*a(row,col)+a(rrow,col) - enddo - b(rrow)=m*b(row)+b(rrow) - endif - enddo - enddo -! back substitution now - - x(1)=b(n)/a(n,1) - do row=n-1,1,-1 - x(n-row+1)=b(row) - do col=1,(n-row) - x(n-row+1)=(x(n-row+1)-a(row,col)*x(col)) - enddo - - x(n-row+1)=(x(n-row+1)/a(row,(n-row)+1)) - enddo - - return - END SUBROUTINE gelim - - SUBROUTINE harm_ana_out - !!---------------------------------------------------------------------- - !! *** ROUTINE harm_ana_init *** - !! - !! ** Purpose : initialization of .... - !! - !! ** Method : blah blah blah ... - !! - !! ** input : Namlist namexa - !! - !! ** Action : ... - !! - !! history : - !! 9.0 ! 03-08 (Autor Names) Original code - !!---------------------------------------------------------------------- - USE dianam ! build name of file (routine) - - !! * local declarations - INTEGER :: ji, jj, jk, jgrid, jh ! dummy loop indices -! INTEGER :: nh_T -! INTEGER :: nid_harm -! CHARACTER (len=40) :: clhstnamt, clop1, clop2 ! temporary names -! CHARACTER (len=40) :: clhstnamu, clhstnamv ! temporary names - CHARACTER (len=40) :: suffix -! REAL(wp) :: zsto1, zsto2, zout, zmax, zjulian, zdt, zmdi ! temporary scalars - - do jgrid=1,nvar_2d - do jh=1,nb_ana - h_out2D = 0.0 - g_out2D = 0.0 - do jj=1,nlcj - do ji=1,nlci - cca=g_cosamp2D(jh,ji,jj,jgrid) - ssa=g_sinamp2D(jh,ji,jj,jgrid) - h_out2D(ji,jj)=sqrt(cca**2+ssa**2) - IF (cca.eq.0.0 .and. ssa.eq.0.0) THEN - g_out2D(ji,jj)= 0.0_wp - ELSE - g_out2D(ji,jj)=(180.0/rpi)*atan2(ssa,cca) - ENDIF - IF (h_out2D(ji,jj).ne.0) THEN - h_out2D(ji,jj)=h_out2D(ji,jj)/anaf(jh) - ENDIF - IF (g_out2D(ji,jj).ne.0) THEN !Correct and take modulus - g_out2D(ji,jj) = g_out2D(ji,jj) + MOD( (anau(jh)+anav(jh))/rad , 360.0) - if (g_out2D(ji,jj).gt.360.0) then - g_out2D(ji,jj)=g_out2D(ji,jj)-360.0 - else if (g_out2D(ji,jj).lt.0.0) then - g_out2D(ji,jj)=g_out2D(ji,jj)+360.0 - endif - ENDIF - enddo - enddo - ! - ! NETCDF OUTPUT - suffix = TRIM( m_varName2d( m_posi_2d(jgrid) ) ) - CALL iom_put( TRIM(Wave(ntide_all(jh))%cname_tide)//'amp_'//TRIM(suffix), h_out2D(:,:) ) - CALL iom_put( TRIM(Wave(ntide_all(jh))%cname_tide)//'pha_'//TRIM(suffix), g_out2D(:,:) ) - - enddo - enddo -! -! DO THE SAME FOR 3D VARIABLES -! - do jgrid=1,nvar_3d - do jh=1,nb_ana - h_out3D = 0.0 - g_out3D = 0.0 - DO jk=1,jpkm1 - do jj=1,nlcj - do ji=1,nlci - cca=g_cosamp3D(jh,ji,jj,jk,jgrid) - ssa=g_sinamp3D(jh,ji,jj,jk,jgrid) - h_out3D(ji,jj,jk)=sqrt(cca**2+ssa**2) - IF (cca.eq.0.0 .and. ssa.eq.0.0) THEN - g_out3D(ji,jj,jk) = 0.0_wp - ELSE - g_out3D(ji,jj,jk) = (180.0/rpi)*atan2(ssa,cca) - ENDIF - IF (h_out3D(ji,jj,jk).ne.0) THEN - h_out3D(ji,jj,jk) = h_out3D(ji,jj,jk)/anaf(jh) - ENDIF - IF (g_out3D(ji,jj,jk).ne.0) THEN !Correct and take modulus - g_out3D(ji,jj,jk) = g_out3D(ji,jj,jk) + MOD( (anau(jh)+anav(jh))/rad , 360.0) - if (g_out3D(ji,jj,jk).gt.360.0) then - g_out3D(ji,jj,jk) = g_out3D(ji,jj,jk)-360.0 - else if (g_out3D(ji,jj,jk).lt.0.0) then - g_out3D(ji,jj,jk) = g_out3D(ji,jj,jk)+360.0 - endif - ENDIF - enddo ! ji - enddo ! jj - ENDDO ! jk - ! - ! NETCDF OUTPUT - suffix = TRIM( m_varName3d( m_posi_3d(jgrid) ) ) - IF(lwp) WRITE(numout,*) "harm_ana_out", suffix - CALL iom_put( TRIM(Wave(ntide_all(jh))%cname_tide)//'amp_'//TRIM(suffix), h_out3D(:,:,:) ) - CALL iom_put( TRIM(Wave(ntide_all(jh))%cname_tide)//'pha_'//TRIM(suffix), g_out3D(:,:,:) ) - enddo ! jh - enddo ! jgrid -! - END SUBROUTINE harm_ana_out -! - SUBROUTINE harm_rst_write(kt) - !!---------------------------------------------------------------------- - !! *** ROUTINE harm_ana_init *** - !! - !! ** Purpose : To write out cummulated Tidal Harmomnic data to file for - !! restarting - !! - !! ** Method : restart files will be dated by default - !! - !! ** input : - !! - !! ** Action : ... - !! - !! history : - !! 0.0 ! 01-16 (Enda O'Dea) Original code - !! ASSUMES dated file for rose , can change later to be more generic - !!---------------------------------------------------------------------- - INTEGER, INTENT(in) :: kt ! ocean time-step - !! - INTEGER :: jh, j2d, j3d - CHARACTER(LEN=20) :: clkt ! ocean time-step define as a character - CHARACTER(LEN=50) :: clname ! ocean output restart file name - CHARACTER(LEN=150) :: clpath ! full path to ocean output restart file - CHARACTER(LEN=250) :: clfinal ! full name - - !restart file - DO j2d=1,nvar_2d - CALL iom_rstput( kt, nitrst, numrow, 'Mean_'//TRIM(m_varName2d( m_posi_2d(j2d) )), g_cumul_var2D( 1, :, :, j2d ) ) - DO jh=1,nb_ana - CALL iom_rstput( kt, nitrst, numrow, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName2d( m_posi_2d(j2d) ))//'_cos', g_cumul_var2D( jh*2 , :, :, j2d ) ) - CALL iom_rstput( kt, nitrst, numrow, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName2d( m_posi_2d(j2d) ))//'_sin', g_cumul_var2D( jh*2+1, :, :, j2d ) ) - ENDDO - ENDDO - - DO j3d=1,nvar_3d - CALL iom_rstput( kt, nitrst, numrow, 'Mean_'//TRIM(m_varName2d( m_posi_3d(j3d) )), g_cumul_var3D( 1, :, :, :, j3d ) ) - DO jh=1,nb_ana - CALL iom_rstput( kt, nitrst, numrow, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName3d( m_posi_3d(j3d) ))//'_cos', g_cumul_var3D( jh*2 , :, :, :, j3d ) ) - CALL iom_rstput( kt, nitrst, numrow, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName3d( m_posi_3d(j3d) ))//'_sin', g_cumul_var3D( jh*2+1, :, :, :, j3d ) ) - ENDDO - ENDDO - - IF(lwp) THEN - IF( kt > 999999999 ) THEN ; WRITE(clkt, * ) kt - ELSE ; WRITE(clkt, '(i8.8)') kt - ENDIF - clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_restart_harm_ana.bin" - clpath = TRIM(cn_ocerst_outdir) - IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' - IF (lwp) WRITE(numout,*) 'Open tidal harmonics restart file for writing: ',TRIM(clpath)//clname - - WRITE(clfinal,'(a)') trim(clpath)//trim(clname) - OPEN( 66, file=TRIM(clfinal), form='unformatted', access="stream" ) - WRITE(66) cc - WRITE(66) anau - WRITE(66) anav - WRITE(66) anaf - WRITE(66) fjulday_startharm - CLOSE(66) - WRITE(numout,*) '----------------------------' - WRITE(numout,*) ' harm_rst_write: DONE ' - WRITE(numout,*) cc - WRITE(numout,*) anaf - WRITE(numout,*) fjulday_startharm - WRITE(numout,*) '----------------------------' - ENDIF - - END SUBROUTINE harm_rst_write - - SUBROUTINE harm_rst_read - !!---------------------------------------------------------------------- - !! *** ROUTINE harm_ana_init *** - !! - !! ** Purpose : To read in cummulated Tidal Harmomnic data to file for - !! restarting - !! - !! ** Method : - !! - !! ** input : - !! - !! ** Action : ... - !! - !! history : - !! 0.0 ! 01-16 (Enda O'Dea) Original code - !! ASSUMES dated file for rose , can change later to be more generic - !!---------------------------------------------------------------------- - CHARACTER(LEN=20) :: clkt ! ocean time-step define as a character - CHARACTER(LEN=50) :: clname ! ocean output restart file name - CHARACTER(LEN=150) :: clpath ! full path to ocean output restart file - CHARACTER(LEN=250) :: clfinal ! full name - INTEGER :: jh, j2d, j3d - - IF( nit000 > 999999999 ) THEN ; WRITE(clkt, * ) nit000-1 - ELSE ; WRITE(clkt, '(i8.8)') nit000-1 - ENDIF - clname = TRIM(cexper)//"_"//TRIM(ADJUSTL(clkt))//"_restart_harm_ana.bin" - clpath = TRIM(cn_ocerst_outdir) - IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' - - IF (lwp) WRITE(numout,*) 'Open tidal harmonics restart file for reading: ',TRIM(clpath)//clname - - DO j2d=1,nvar_2d - CALL iom_get( numror,jpdom_autoglo, 'Mean_'//TRIM(m_varName2d( m_posi_2d(j2d) )), g_cumul_var2D( 1, :, :, j2d ) ) - IF(lwp) WRITE(numout,*) "2D", j2d, m_posi_2d(j2d), m_varName2d( m_posi_2d(j2d) ) - DO jh=1,nb_ana - CALL iom_get( numror,jpdom_autoglo, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName2d( m_posi_2d(j2d) ))//'_cos', g_cumul_var2D( jh*2 , :, :, j2d ) ) - CALL iom_get( numror,jpdom_autoglo, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName2d( m_posi_2d(j2d) ))//'_sin', g_cumul_var2D( jh*2+1, :, :, j2d ) ) - ENDDO - ENDDO - - DO j3d=1,nvar_3d - CALL iom_get( numror,jpdom_autoglo, 'Mean_'//TRIM(m_varName2d( m_posi_3d(j3d) )), g_cumul_var3D( 1, :, :, :, j3d ) ) - IF(lwp) WRITE(numout,*) "3D", j3d, m_posi_3d(j3d), m_varName3d( m_posi_3d(j3d) ) - - DO jh=1,nb_ana - CALL iom_get( numror,jpdom_autoglo, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName3d( m_posi_3d(j3d) ))//'_cos', g_cumul_var3D( jh*2 , :, :, :, j3d ) ) - CALL iom_get( numror,jpdom_autoglo, TRIM(Wave(ntide_all(jh))%cname_tide)//"_"//TRIM(m_varName3d( m_posi_3d(j3d) ))//'_sin', g_cumul_var3D( jh*2+1, :, :, :, j3d ) ) - ENDDO - ENDDO - - WRITE(clfinal,'(a)') trim(clpath)//trim(clname) - OPEN( 66, file=TRIM(clfinal), form='unformatted', access="stream" ) - READ(66) cc - READ(66) anau - READ(66) anav - READ(66) anaf - READ(66) fjulday_startharm - CLOSE(66) - - IF(lwp) THEN - WRITE(numout,*) '----------------------------' - WRITE(numout,*) ' Checking anaf is correct' - WRITE(numout,*) cc - WRITE(numout,*) anaf - WRITE(numout,*) fjulday_startharm - WRITE(numout,*) '----------------------------' - ENDIF - - END SUBROUTINE harm_rst_read - - !!====================================================================== -#else -!!--------------------------------------------------------------------------------- -!! Dummy module NO harmonic Analysis -!!--------------------------------------------------------------------------------- - LOGICAL, PUBLIC, PARAMETER :: lk_diaharm_fast = .FALSE. ! to be run or not - - CONTAINS - SUBROUTINE harm_rst_write(kt) ! Dummy routine - END SUBROUTINE harm_rst_write - SUBROUTINE harm_rst_read ! Dummy routine - END SUBROUTINE harm_rst_read - SUBROUTINE harm_ana_out ! Dummy routine - END SUBROUTINE harm_ana_out - SUBROUTINE harm_ana_init - END SUBROUTINE harm_ana_init - SUBROUTINE harm_ana( kt ) -!--- NB : end call not properly written - END SUBROUTINE harm_ana -! END SUBROUTINE harm_ana_init -!--- END NB - SUBROUTINE gelim (a,b,x,n) -!--- NB : end call not properly written - END SUBROUTINE gelim -! END SUBROUTINE gelim (a,b,x,n) -!--- END NB -#endif - -END MODULE diaharm_fast diff --git a/MY_SRC/step_oce.F90 b/MY_SRC/step_oce.F90 deleted file mode 100644 index d4e0cbc..0000000 --- a/MY_SRC/step_oce.F90 +++ /dev/null @@ -1,127 +0,0 @@ -MODULE step_oce - !!====================================================================== - !! *** MODULE step_oce *** - !! Ocean time-stepping : module used in both initialisation phase and time stepping - !!====================================================================== - !! 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 zdf_oce ! ocean vertical physics variables - - 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 sbctide ! Tide initialisation - USE sbcwave ! Wave intialisation - - USE traqsr ! solar radiation penetration (tra_qsr 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 tranxt ! time-stepping (tra_nxt routine) - USE tranpc ! non-penetrative convection (tra_npc routine) - - USE eosbn2 ! equation of state (eos_bn2 routine) - - USE divhor ! horizontal divergence (div_hor routine) - USE dynadv ! advection (dyn_adv routine) - USE dynbfr ! Bottom friction terms (dyn_bfr 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 dynnxt ! time-stepping (dyn_nxt routine) - - USE stopar ! Stochastic parametrization (sto_par routine) - USE stopts - - 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 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 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 zdftmx ! tide-induced vertical mixing (zdf_tmx routine) - USE zdfbfr ! bottom friction (zdf_bfr routine) - USE zdftke ! TKE vertical mixing (zdf_tke routine) - USE zdfgls ! GLS vertical mixing (zdf_gls routine) - USE zdfddm ! double diffusion mixing (zdf_ddm routine) - USE zdfevd ! enhanced vertical diffusion (zdf_evd routine) - USE zdfric ! Richardson vertical mixing (zdf_ric routine) - USE zdfmxl ! Mixed-layer depth (zdf_mxl routine) - USE zdfqiao !Qiao module wave induced mixing (zdf_qiao routine) - - USE step_diu ! Time stepping for diurnal sst - USE diurnal_bulk ! diurnal SST bulk routines (diurnal_sst_takaya routine) - USE cool_skin ! diurnal cool skin correction (diurnal_sst_coolskin routine) - 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 diaharm -!--- NB for restart hamonic analysis - USE diaharm_fast ! harmonic analysis of tides (harm_ana routine) -!--- END NB ----------------------------------- - USE diacfl - 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 - USE stpctl ! time stepping control (stp_ctl routine) - USE restart ! ocean restart (rst_wri routine) - USE prtctl ! Print control (prt_ctl routine) - - USE diaobs ! Observation operator - - USE in_out_manager ! I/O manager - USE iom ! - USE lbclnk - USE timing ! Timing - -#if defined key_iomput - USE xios -#endif -#if defined key_agrif - USE agrif_opa_sponge ! Momemtum and tracers sponges - USE agrif_opa_update ! Update (2-way nesting) -#endif -#if defined key_top - USE trcstp ! passive tracer time-stepping (trc_stp routine) -#endif - !!---------------------------------------------------------------------- - !! NEMO/OPA 3.7 , NEMO Consortium (2014) - !! $Id: step_oce.F90 7646 2017-02-06 09:25:03Z timgraham $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) - !!====================================================================== -END MODULE step_oce diff --git a/MY_SRC/stpctl.F90 b/MY_SRC/stpctl.F90 deleted file mode 100644 index ededc36..0000000 --- a/MY_SRC/stpctl.F90 +++ /dev/null @@ -1,189 +0,0 @@ -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 - !!---------------------------------------------------------------------- - - !!---------------------------------------------------------------------- - !! stp_ctl : Control the run - !!---------------------------------------------------------------------- - USE oce ! ocean dynamics and tracers variables - USE dom_oce ! ocean space and time domain variables - USE c1d ! 1D vertical configuration - ! - USE in_out_manager ! I/O manager - USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE lib_mpp ! distributed memory computing - USE lib_fortran ! Fortran routines library - - IMPLICIT NONE - PRIVATE - - PUBLIC stp_ctl ! routine called by step.F90 - !!---------------------------------------------------------------------- - !! NEMO/OPA 3.3 , NEMO Consortium (2010) - !! $Id: stpctl.F90 7852 2017-03-30 14:04:54Z cetlod $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) - !!---------------------------------------------------------------------- -CONTAINS - - SUBROUTINE stp_ctl( kt, kindic ) - !!---------------------------------------------------------------------- - !! *** ROUTINE stp_ctl *** - !! - !! ** Purpose : Control the run - !! - !! ** Method : - Save the time step in numstp - !! - Print it each 50 time steps - !! - Stop the run IF problem ( indic < 0 ) - !! - !! ** Actions : 'time.step' file containing the last ocean time-step - !! - !!---------------------------------------------------------------------- - INTEGER, INTENT(in ) :: kt ! ocean time-step index - INTEGER, INTENT(inout) :: kindic ! error indicator - !! - INTEGER :: ji, jj, jk ! dummy loop indices - INTEGER :: ii, ij, ik ! local integers - REAL(wp) :: velmax2, zsmin, zssh2, zsshmax ! local scalars - INTEGER, DIMENSION(3) :: ilocu ! - INTEGER, DIMENSION(2) :: ilocs ! - !!---------------------------------------------------------------------- - ! - IF( kt == nit000 .AND. lwp ) THEN - WRITE(numout,*) - WRITE(numout,*) 'stp_ctl : time-stepping control' - WRITE(numout,*) '~~~~~~~' - ! open time.step file - CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) - ENDIF - ! - IF(lwp) WRITE ( numstp, '(1x, i8)' ) kt !* save the current time step in numstp - IF(lwp) REWIND( numstp ) ! -------------------------- - ! - ! !* Test maximum of velocity - ! ! ------------------------ - !! velmax2 = MAXVAL( ABS( un(:,:,:) ) ) ! slower than the following loop on NEC SX5 - velmax2 = 0.e0 - DO jk = 1, jpk - DO jj = 1, jpj - DO ji = 1, jpi - velmax2 = MAX( velmax2,un(ji,jj,jk)**2 + vn(ji,jj,jk)**2 ) - END DO - END DO - END DO - IF( lk_mpp ) CALL mpp_max( velmax2 ) ! max over the global domain - ! - IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' 3d speed2 max: ', velmax2 - ! - IF( velmax2 > 20.e0**2 ) THEN - IF( lk_mpp ) THEN - CALL mpp_maxloc( un(:,:,:)**2+vn(:,:,:)**2,umask,velmax2,ii,ij,ik) - ELSE - ilocu = MAXLOC( un(:,:,:)**2 + vn(:,:,:)**2 ) - ii = ilocu(1) + nimpp - 1 - ij = ilocu(2) + njmpp - 1 - ik = ilocu(3) - ENDIF - IF(lwp) THEN - WRITE(numout,cform_err) - WRITE(numout,*) ' stpctl: the speed is larger than 20 m/s' - WRITE(numout,*) ' ====== ' - WRITE(numout,9400) kt, velmax2, ii, ij, ik - WRITE(numout,*) - WRITE(numout,*) ' output of last fields in numwso' - ENDIF - kindic = -3 - ENDIF -9400 FORMAT (' kt=',i6,' max abs(vel)**2: ',1pg11.4,', i j k: ',3i5) - ! - ! !* Test minimum of salinity - ! ! ------------------------ - !! zsmin = MINVAL( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) slower than the following loop on NEC SX5 - zsmin = 100._wp - DO jj = 2, jpjm1 - DO ji = 1, jpi - IF( tmask(ji,jj,1) == 1) zsmin = MIN(zsmin,tsn(ji,jj,1,jp_sal)) - END DO - END DO - IF( lk_mpp ) CALL mpp_min( zsmin ) ! min over the global domain - ! - IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' SSS min:', zsmin - ! - IF( zsmin < 0.) THEN - IF (lk_mpp) THEN - CALL mpp_minloc ( tsn(:,:,1,jp_sal),tmask(:,:,1), zsmin, ii,ij ) - ELSE - ilocs = MINLOC( tsn(:,:,1,jp_sal), mask = tmask(:,:,1) == 1.e0 ) - ii = ilocs(1) + nimpp - 1 - ij = ilocs(2) + njmpp - 1 - ENDIF - ! - IF(lwp) THEN - WRITE(numout,cform_err) - WRITE(numout,*) 'stp_ctl : NEGATIVE sea surface salinity' - WRITE(numout,*) '======= ' - WRITE(numout,9500) kt, zsmin, ii, ij - WRITE(numout,*) - WRITE(numout,*) ' output of last fields in numwso' - ENDIF - kindic = -3 - ENDIF -9500 FORMAT (' kt=',i6,' min SSS: ',1pg11.4,', i j: ',2i5) - ! - ! - IF( lk_c1d ) RETURN ! No log file in case of 1D vertical configuration - - ! log file (ssh statistics) - ! -------- !* ssh statistics (and others...) - IF( kt == nit000 .AND. lwp ) THEN ! open ssh statistics file (put in solver.stat file) - CALL ctl_opn( numsol, 'solver.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) - ENDIF - ! - zsshmax = 0.e0 - DO jj = 1, jpj - DO ji = 1, jpi - IF( tmask(ji,jj,1) == 1) zsshmax = MAX( zsshmax, ABS(sshn(ji,jj)) ) - END DO - END DO - IF( lk_mpp ) CALL mpp_max( zsshmax ) ! min over the global domain - ! - IF( MOD( kt, nwrite ) == 1 .AND. lwp ) WRITE(numout,*) ' ==>> time-step= ',kt,' ssh max:', zsshmax - ! - IF( zsshmax > 10.e0 ) THEN - IF (lk_mpp) THEN - CALL mpp_maxloc( ABS(sshn(:,:)),tmask(:,:,1),zsshmax,ii,ij) - ELSE - ilocs = MAXLOC( ABS(sshn(:,:)) ) - ii = ilocs(1) + nimpp - 1 - ij = ilocs(2) + njmpp - 1 - ENDIF - ! - IF(lwp) THEN - WRITE(numout,cform_err) - WRITE(numout,*) 'stp_ctl : the ssh is larger than 10m' - WRITE(numout,*) '======= ' - WRITE(numout,9600) kt, zsshmax, ii, ij - WRITE(numout,*) - WRITE(numout,*) ' output of last fields in numwso' - ENDIF - kindic = -3 - ENDIF -9600 FORMAT (' kt=',i6,' max ssh: ',1pg11.4,', i j: ',2i5) - ! - zssh2 = glob_sum( sshn(:,:) * sshn(:,:) ) - ! - IF(lwp) WRITE(numsol,9700) kt, zssh2, velmax2, zsmin ! ssh statistics - ! -9700 FORMAT(' it :', i8, ' ssh2: ', d23.16, ' vel2max: ',d23.16,' SSSmin: ',d23.16) - ! - END SUBROUTINE stp_ctl - - !!====================================================================== -END MODULE stpctl diff --git a/MY_SRC/tide_FES14.h90 b/MY_SRC/tide_FES14.h90 deleted file mode 100644 index 3998e80..0000000 --- a/MY_SRC/tide_FES14.h90 +++ /dev/null @@ -1,114 +0,0 @@ - !!---------------------------------------------------------------------- - !! History : 3.2 ! 2007 (O. Le Galloudec) Original code - !!---------------------------------------------------------------------- - !! TIDES ADDED ! 2017 (Nico Bruneau) - !! Following this document that seems to match implemented code - !! https://docs.lib.noaa.gov/rescue/cgs_specpubs/QB275U35no981924.pdf - !! see page 189 for some proposed values - !! - !! The convention which seems to have been chosen is the Shureman one and - !! not the Cartwright and Tayer (1971) - !! This is probably due to the fact the Schureman has a solar calendar - !! while Cartwright and Tayer is based on a lunar calendar - !! - !! Therefore the coefficient are not the Doodson number but the one - !! defined by Schureman. For example : - !! M2 : Doodson : 2 0 0 0 0 0 - !! Schureman : 2 -2 2 0 0 0 - !! - !! Components 1-34 are for FES 2014 - !! Components >= 35 are the one that were initially present in NEMO and not in FES14 - !! keep in mind than equitide coefficient have been ajusted for the - !! 34 FES 2014 constituents - !! - !! The different coefficient are as follows - !! - nt = T = Number of Julian centuries (36625 days) from Greenwich mean noon on December 31, 1899. - !! = Hour angle of mean sun - !! - ns = s = mean longitude of the moon - !! - nh = h = mean longitude of the sun - !! - np = p = mean longitude of the lunar perigee - !! - np1 = p1 = mean longitude of the solar perigee - !! - shift appears in table as a bias in degree - !! - nksi Coefficient for the longitude in moon's orbit of lunar intersection - !! - nu0 Coefficient for the right ascension of lunar intersection - !! - nu1 Coefficient for the term in argument of lunisolar constituent K1 - !! - nu2 Coefficient for the term in argument of lunisolar constituent K2 - !! - R = ??? - !! - Formula = Nodal factor function; see the table of Schureman. Implemented in tide_mod.F90 - !! - !! The equitide parameter seems to be the equilibrium tide amplitude corrected - !! with the C_n^m coefficient: see Cartwright and Tayer (1971) equation 12 - !! and Table 2 - !! As an example in their Table 4c (p66), M2 (200000) has an amplitude of - !! around 0.63186 m - !! Table 2, give us a correction of m = 2, n = 2 (semi-diurnal) - !! 0.63186*3*sqrt( 5 / 96 / pi ) = 0.24407 - !! very close to the one define originally here : 0.242297 - !! Third order terms are neglected - !! - !! So to correct (to match what is implemented in sbctide.F90 - take care CT71 uses co-latitude): - !! - long wave : Amplitude from CT71 * [ -1 * sqrt( 5 / 4 / pi ) ] - !! - diurnal : Amplitude from CT71 * [ -3/2 * sqrt( 5 / 24 / pi ) ] - !! - semi-diur : Amplitude from CT71 * [ 3 * sqrt( 5 / 96 / pi ) ] - !! - !! ATTENTION: convention seems to be to have a positive coefficient and a 180 shift to - !! represent negative value. to be confirmed though. - !! - !! All equtide were computed using the last epocs from Cartwright and Tayer (1971) multiply by - !! the corresponding coefficient of their table 2 - !! - !! nutide is used to compute tide potential - it uses a different formulation depending of nutide - !! see sbctide.F90 in function tide_init_potential - !! - !! Some random note - !! in cnes fes tool: - !! Msf has nksi = 2 and nnu0 = -2 which is reverse from Schureman (I kept the Schureman one) - !! - !!---------------------------------------------------------------------- - ! - ! !! name_tide , equitide , nutide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! - ! !! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !! - ! - ! Long Period Tides - Wave( 1) = tide( 'SA' , 0.003103 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave( 2) = tide( 'SSA' , 0.019523 , 0 , 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave( 3) = tide( 'MM' , 0.022191 , 0 , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) - Wave( 4) = tide( 'MF' , 0.042023 , 0 , 0 , 2 , 0 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) - Wave( 5) = tide( 'MTM' , 0.008042 , 0 , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) - Wave( 6) = tide( 'MSF' , 0.003671 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , -2 , 2 , 0 , 0 , 0 , 78 ) - Wave( 7) = tide( 'MSQM' , 0.001293 , 0 , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) - ! - ! Diurnal Tides - Wave( 8) = tide( 'K1' ,-0.142442 , 1 , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) - Wave( 9) = tide( 'O1' , 0.101277 , 1 , 1 , -2 , 1 , 0 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) - Wave(10) = tide( 'Q1' , 0.019383 , 1 , 1 , -3 , 1 , 1 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) - Wave(11) = tide( 'P1' , 0.047145 , 1 , 1 , 0 , -1 , 0 , 0 , +90 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave(12) = tide( 'S1' ,-0.001116 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave(13) = tide( 'J1' ,-0.007961 , 1 , 1 , 1 , 1 , -1 , 0 , -90 , 0 , -1 , 0 , 0 , 0 , 76 ) - ! - ! Semi-Diurnal Tides - Wave(14) = tide( 'M2' , 0.244083 , 2 , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - Wave(15) = tide( 'N2' , 0.046720 , 2 , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - Wave(16) = tide( 'S2' , 0.113565 , 2 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave(17) = tide( 'K2' , 0.030875 , 2 , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) - Wave(18) = tide( 'L2' , 0.006903 , 2 , 2 , -1 , 2 , -1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 215 ) - Wave(19) = tide( 'T2' , 0.006644 , 2 , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave(20) = tide( 'R2' , 0.000950 , 2 , 2 , 0 , 1 , 0 , -1 , +180 , 2 , 0 , 0 , 0 , 0 , 0 ) - ! - Wave(21) = tide( 'MU2' , 0.007451 , 2 , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - Wave(22) = tide( 'NU2' , 0.008873 , 2 , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - Wave(23) = tide( '2N2' , 0.006176 , 2 , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - Wave(24) = tide( 'MKS2' , 0.000000 , 2 , 2 , -2 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , -2 , 0 , 4 ) - Wave(25) = tide( 'LA2' , 0.001800 , 2 , 2 , -1 , 0 , 1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 78 ) - Wave(26) = tide( 'EPS2' , 0.001796 , 2 , 2 , -5 , 4 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - ! - ! Harmonic and others - Wave(27) = tide( 'M3' , 0.000000 , 3 , 3 , -3 , 3 , 0 , 0 , 0 , 3 , -3 , 0 , 0 , 0 , 149 ) - Wave(28) = tide( 'M4' , 0.000000 , 4 , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) - Wave(29) = tide( 'M6' , 0.000000 , 6 , 6 , -6 , 6 , 0 , 0 , 0 , 6 , -6 , 0 , 0 , 0 , 18 ) - Wave(30) = tide( 'M8' , 0.000000 , 8 , 8 , -8 , 8 , 0 , 0 , 0 , 8 , -8 , 0 , 0 , 0 , 20 ) - Wave(31) = tide( 'N4' , 0.000000 , 4 , 4 , -6 , 4 , 2 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) - Wave(32) = tide( 'S4' , 0.000000 , 4 , 4 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) - Wave(33) = tide( 'MN4' , 0.000000 , 4 , 4 , -5 , 4 , 1 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) - Wave(34) = tide( 'MS4' , 0.000000 , 4 , 4 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) - ! diff --git a/NEMO_4.0.4_surge/CHANGES.rst b/NEMO_4.0.4_surge/CHANGES.rst new file mode 100644 index 0000000..90a0808 --- /dev/null +++ b/NEMO_4.0.4_surge/CHANGES.rst @@ -0,0 +1,7 @@ +******* +Changes +******* + +.. todo:: + + List the main additions of the the new release diff --git a/NEMO_4.0.4_surge/CONTRIBUTING.rst b/NEMO_4.0.4_surge/CONTRIBUTING.rst new file mode 100644 index 0000000..780797f --- /dev/null +++ b/NEMO_4.0.4_surge/CONTRIBUTING.rst @@ -0,0 +1,73 @@ +************ +Contributing +************ + +.. todo:: + + + +.. contents:: + :local: + +Sending feedbacks +================= + +| Sending feedbacks is a useful way to contribute to NEMO efficency and reliability. Before doing so, + please check here :forge:`search ` in wiki, tickets, forum and online + documentation if the subject has already been discussed. You can either contribute to an existing + discussion, or +| Create an entry for the discussion online, according to your needs + +- You have a question: create a topic in the appropriate :forge:`discussion ` +- You would like to raise and issue: open a new ticket of the right type depending of its severity + + - "Unavoidable" :forge:`newticket?type=Bug ` + + - "Workable" :forge:`newticket?type=Defect ` + +Please follow the guidelines and try to be as specific as possible in the ticket description. + +New development +=============== + +You have build a development relevant for NEMO shared reference: an addition of the source code, +a full fork of the reference, ... + +You may want to share it with the community (see Hack below) or to propose it for implementation in the future +NEMO release (see Proposal / Task below). + +The proposals for developments to be included in the shared NEMO reference are first examined by NEMO Developers +Committee / Scientific Advisory Board. +The implementation of a new development requires some additionnal work from the intial developer. +These tasks will need to be scheduled with NEMO System Team. + + +Hack +---- + +You only would like to inform NEMO community about your developments. +You can promote your work on NEMO forum gathering the contributions fromof the community by creating +a specific topic here :forge:`discussion/forum/5 ` + + +Proposal / Task +--------------- + +| Your development is quite small, and you would only like to offer it as a possible enhancement. Please suggest it + as an enhancement here :forge:`newticket?type=Enhancement ` . It will be taken in account, if + feasible, by NEMO System Team. To ease the process, it is suggested, rather than attaching the modified + routines to the ticket, to highlight the proposed changes by adding to the ticket the output of ``svn diff`` + or ``svn patch`` from your working copy. + +| Your development seems relevant for addition into the future release of NEMO shared reference. + Implementing it into NEMO shared reference following the usual quality control will require some additionnal work + from you and also from the NEMO System Team in charge of NEMO development. In order to evaluate the work, + your suggestion should be send as a proposed enhancement here :forge:`newticket?type=Enhancement ` + including description of the development, its implementation, and the existing validations. + + The proposed enhancement will be examined by NEMO Developers Committee / Scientific Advisory Board. + Once approved by the Committee, the assicated development task can be scheduled in NEMO development work plan, + and tasks distributed between you as initial developer and PI of this development action, and the NEMO System Team. + + Once sucessful (meeting the usual quality control steps) this action will allow the merge of these developments with + other developments of the year, building the future NEMO. diff --git a/NEMO_4.0.4_surge/INSTALL.rst b/NEMO_4.0.4_surge/INSTALL.rst new file mode 100644 index 0000000..4ecf8dd --- /dev/null +++ b/NEMO_4.0.4_surge/INSTALL.rst @@ -0,0 +1,270 @@ +******************* +Build the framework +******************* + +.. todo:: + + + +.. contents:: + :local: + +Prerequisites +============= + +| The NEMO source code is written in *Fortran 95* and + some of its prerequisite tools and libraries are already included in the download. +| It contains the AGRIF_ preprocessing program ``conv``; the FCM_ build system and + the IOIPSL_ library for parts of the output. + +System dependencies +------------------- + +In the first place the other requirements should be provided natively by your system or +can be installed from the official repositories of your Unix-like distribution: + +- *Perl* interpreter +- *Fortran* compiler (``ifort``, ``gfortran``, ``pgfortran``, ...), +- *Message Passing Interface (MPI)* implementation (e.g. |OpenMPI|_ or |MPICH|_). +- |NetCDF|_ library with its underlying |HDF|_ + +**NEMO, by default, takes advantage of some MPI features introduced into the MPI-3 standard.** + +.. hint:: + + The MPI implementation is not strictly essential + since it is possible to compile and run NEMO on a single processor. + However most realistic configurations will require the parallel capabilities of NEMO and + these use the MPI standard. + +.. note:: + + On older systems, that do not support MPI-3 features, + the ``key_mpi2`` preprocessor key should be used at compile time. + This will limit MPI features to those defined within the MPI-2 standard + (but will lose some performance benefits). + +.. |OpenMPI| replace:: *OpenMPI* +.. _OpenMPI: https://www.open-mpi.org +.. |MPICH| replace:: *MPICH* +.. _MPICH: https://www.mpich.org +.. |NetCDF| replace:: *Network Common Data Form (NetCDF)* +.. _NetCDF: https://www.unidata.ucar.edu +.. |HDF| replace:: *Hierarchical Data Form (HDF)* +.. _HDF: https://www.hdfgroup.org + +Specifics for NetCDF and HDF +---------------------------- + +NetCDF and HDF versions from official repositories may have not been compiled with MPI support. +However access to all the options available with the XIOS IO-server will require +the parallelism of these libraries. + +| **To satisfy these requirements, it is common to have to compile from source + in this order HDF (C library) then NetCDF (C and Fortran libraries)** +| It is also necessary to compile these libraries with the same version of the MPI implementation that + both NEMO and XIOS (see below) have been compiled and linked with. + +.. hint:: + + | It is difficult to define the options for the compilation as + they differ from one architecture to another according to + the hardware used and the software installed. + | The following is provided without any warranty + + .. code-block:: console + + $ ./configure [--{enable-fortran,disable-shared,enable-parallel}] ... + + It is recommended to build the tests ``--enable-parallel-tests`` and run them with ``make check`` + +Particular versions of these libraries may have their own restrictions. +State the following requirements for netCDF-4 support: + +.. caution:: + + | When building NetCDF-C library versions older than 4.4.1, use only HDF5 1.8.x versions. + | Combining older NetCDF-C versions with newer HDF5 1.10 versions will create superblock 3 files + that are not readable by lots of older software. + +Extract and install XIOS +======================== + +With the sole exception of running NEMO in mono-processor mode +(in which case output options are limited to those supported by the ``IOIPSL`` library), +diagnostic outputs from NEMO are handled by the third party ``XIOS`` library. +It can be used in two different modes: + +:*attached*: Every NEMO process also acts as a XIOS server +:*detached*: Every NEMO process runs as a XIOS client. + Output is collected and collated by external, stand-alone XIOS server processors. + +Instructions on how to install XIOS can be found on its :xios:`wiki<>`. + +.. hint:: + + It is recommended to use XIOS 2.5 release. + This version should be more stable (in terms of future code changes) than the XIOS trunk. + It is also the one used by the NEMO system team when testing all developments and new releases. + + This particular version has its own branch and can be checked out with: + + .. code:: console + + $ svn co https://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5 + +Download and install the NEMO code +================================== + +Checkout the NEMO sources +------------------------- + +.. code:: console + + $ svn co https://forge.ipsl.jussieu.fr/nemo/svn/NEMO/releases/release-4.0-HEAD + +Description of 1\ :sup:`st` level tree structure +------------------------------------------------ + ++---------------+----------------------------------------+ +| :file:`arch` | Compilation settings | ++---------------+----------------------------------------+ +| :file:`cfgs` | :doc:`Reference configurations ` | ++---------------+----------------------------------------+ +| :file:`doc` | :doc:`Documentation ` | ++---------------+----------------------------------------+ +| :file:`ext` | Dependencies included | +| | (``AGRIF``, ``FCM`` & ``IOIPSL``) | ++---------------+----------------------------------------+ +| :file:`mk` | Compilation scripts | ++---------------+----------------------------------------+ +| :file:`src` | :doc:`Modelling routines ` | ++---------------+----------------------------------------+ +| :file:`tests` | :doc:`Test cases ` | +| | (unsupported) | ++---------------+----------------------------------------+ +| :file:`tools` | :doc:`Utilities ` | +| | to {pre,post}process data | ++---------------+----------------------------------------+ + +Setup your architecture configuration file +------------------------------------------ + +All compiler options in NEMO are controlled using files in :file:`./arch/arch-'my_arch'.fcm` where +``my_arch`` is the name of the computing architecture +(generally following the pattern ``HPCC-compiler`` or ``OS-compiler``). +It is recommended to copy and rename an configuration file from an architecture similar to your owns. +You will need to set appropriate values for all of the variables in the file. +In particular the FCM variables: +``%NCDF_HOME``; ``%HDF5_HOME`` and ``%XIOS_HOME`` should be set to +the installation directories used for XIOS installation + +.. code-block:: sh + + %NCDF_HOME /usr/local/path/to/netcdf + %HDF5_HOME /usr/local/path/to/hdf5 + %XIOS_HOME /home/$( whoami )/path/to/xios-2.5 + %OASIS_HOME /home/$( whoami )/path/to/oasis + +Create and compile a new configuration +====================================== + +The main script to {re}compile and create executable is called :file:`makenemo` located at +the root of the working copy. +It is used to identify the routines you need from the source code, to build the makefile and run it. +As an example, compile a :file:`MY_GYRE` configuration from GYRE with 'my_arch': + +.. code-block:: sh + + ./makenemo –m 'my_arch' –r GYRE -n 'MY_GYRE' + +Then at the end of the configuration compilation, +:file:`MY_GYRE` directory will have the following structure. + ++------------+----------------------------------------------------------------------------+ +| Directory | Purpose | ++============+============================================================================+ +| ``BLD`` | BuiLD folder: target executable, headers, libs, preprocessed routines, ... | ++------------+----------------------------------------------------------------------------+ +| ``EXP00`` | Run folder: link to executable, namelists, ``*.xml`` and IOs | ++------------+----------------------------------------------------------------------------+ +| ``EXPREF`` | Files under version control only for :doc:`official configurations ` | ++------------+----------------------------------------------------------------------------+ +| ``MY_SRC`` | New routines or modified copies of NEMO sources | ++------------+----------------------------------------------------------------------------+ +| ``WORK`` | Links to all raw routines from :file:`./src` considered | ++------------+----------------------------------------------------------------------------+ + +After successful execution of :file:`makenemo` command, +the executable called `nemo` is available in the :file:`EXP00` directory + +More :file:`makenemo` options +----------------------------- + +``makenemo`` has several other options that can control which source files are selected and +the operation of the build process itself. + +.. literalinclude:: ../../../makenemo + :language: text + :lines: 119-143 + :caption: Output of ``makenemo -h`` + +These options can be useful for maintaining several code versions with only minor differences but +they should be used sparingly. +Note however the ``-j`` option which should be used more routinely to speed up the build process. +For example: + +.. code-block:: sh + + ./makenemo –m 'my_arch' –r GYRE -n 'MY_GYRE' -j 8 + +will compile up to 8 processes simultaneously. + +Default behaviour +----------------- + +At the first use, +you need the ``-m`` option to specify the architecture configuration file +(compiler and its options, routines and libraries to include), +then for next compilation, it is assumed you will be using the same compiler. +If the ``-n`` option is not specified the last compiled configuration will be used. + +Tools used during the process +----------------------------- + +* :file:`functions.sh`: bash functions used by ``makenemo``, for instance to create the WORK directory +* :file:`cfg.txt` : text list of configurations and source directories +* :file:`bld.cfg` : FCM rules for compilation + +Examples +-------- + +.. literalinclude:: ../../../makenemo + :language: text + :lines: 146-153 + +Running the model +================= + +Once :file:`makenemo` has run successfully, +the ``nemo`` executable is available in :file:`./cfgs/MY_CONFIG/EXP00`. +For the reference configurations, the :file:`EXP00` folder also contains the initial input files +(namelists, ``*.xml`` files for the IOs, ...). +If the configuration needs other input files, they have to be placed here. + +.. code-block:: sh + + cd 'MY_CONFIG'/EXP00 + mpirun -n $NPROCS ./nemo # $NPROCS is the number of processes + # mpirun is your MPI wrapper + +Viewing and changing list of active CPP keys +============================================ + +For a given configuration (here called ``MY_CONFIG``), +the list of active CPP keys can be found in :file:`./cfgs/'MYCONFIG'/cpp_MY_CONFIG.fcm` + +This text file can be edited by hand or with :file:`makenemo` to change the list of active CPP keys. +Once changed, one needs to recompile ``nemo`` in order for this change to be taken in account. +Note that most NEMO configurations will need to specify the following CPP keys: +``key_iomput`` for IOs and ``key_mpp_mpi`` for parallelism. diff --git a/NEMO_4.0.4_surge/LICENSE b/NEMO_4.0.4_surge/LICENSE new file mode 100644 index 0000000..fcc8df2 --- /dev/null +++ b/NEMO_4.0.4_surge/LICENSE @@ -0,0 +1,506 @@ + +CeCILL FREE SOFTWARE LICENSE AGREEMENT + + + Notice + +This Agreement is a Free Software license agreement that is the result +of discussions between its authors in order to ensure compliance with +the two main principles guiding its drafting: + + * firstly, compliance with the principles governing the distribution + of Free Software: access to source code, broad rights granted to + users, + * secondly, the election of a governing law, French law, with which + it is conformant, both as regards the law of torts and + intellectual property law, and the protection that it offers to + both authors and holders of the economic rights over software. + +The authors of the CeCILL (for Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) +license are: + +Commissariat � l'Energie Atomique - CEA, a public scientific, technical +and industrial research establishment, having its principal place of +business at 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris, France. + +Centre National de la Recherche Scientifique - CNRS, a public scientific +and technological establishment, having its principal place of business +at 3 rue Michel-Ange, 75794 Paris cedex 16, France. + +Institut National de Recherche en Informatique et en Automatique - +INRIA, a public scientific and technological establishment, having its +principal place of business at Domaine de Voluceau, Rocquencourt, BP +105, 78153 Le Chesnay cedex, France. + + + Preamble + +The purpose of this Free Software license agreement is to grant users +the right to modify and redistribute the software governed by this +license within the framework of an open source distribution model. + +The exercising of these rights is conditional upon certain obligations +for users so as to preserve this status for all subsequent redistributions. + +In consideration of access to the source code and the rights to copy, +modify and redistribute granted by the license, users are provided only +with a limited warranty and the software's author, the holder of the +economic rights, and the successive licensors only have limited liability. + +In this respect, the risks associated with loading, using, modifying +and/or developing or reproducing the software by the user are brought to +the user's attention, given its Free Software status, which may make it +complicated to use, with the result that its use is reserved for +developers and experienced professionals having in-depth computer +knowledge. Users are therefore encouraged to load and test the +suitability of the software as regards their requirements in conditions +enabling the security of their systems and/or data to be ensured and, +more generally, to use and operate it in the same conditions of +security. This Agreement may be freely reproduced and published, +provided it is not altered, and that no provisions are either added or +removed herefrom. + +This Agreement may apply to any or all software for which the holder of +the economic rights decides to submit the use thereof to its provisions. + + + Article 1 - DEFINITIONS + +For the purpose of this Agreement, when the following expressions +commence with a capital letter, they shall have the following meaning: + +Agreement: means this license agreement, and its possible subsequent +versions and annexes. + +Software: means the software in its Object Code and/or Source Code form +and, where applicable, its documentation, "as is" when the Licensee +accepts the Agreement. + +Initial Software: means the Software in its Source Code and possibly its +Object Code form and, where applicable, its documentation, "as is" when +it is first distributed under the terms and conditions of the Agreement. + +Modified Software: means the Software modified by at least one +Contribution. + +Source Code: means all the Software's instructions and program lines to +which access is required so as to modify the Software. + +Object Code: means the binary files originating from the compilation of +the Source Code. + +Holder: means the holder(s) of the economic rights over the Initial +Software. + +Licensee: means the Software user(s) having accepted the Agreement. + +Contributor: means a Licensee having made at least one Contribution. + +Licensor: means the Holder, or any other individual or legal entity, who +distributes the Software under the Agreement. + +Contribution: means any or all modifications, corrections, translations, +adaptations and/or new functions integrated into the Software by any or +all Contributors, as well as any or all Internal Modules. + +Module: means a set of sources files including their documentation that +enables supplementary functions or services in addition to those offered +by the Software. + +External Module: means any or all Modules, not derived from the +Software, so that this Module and the Software run in separate address +spaces, with one calling the other when they are run. + +Internal Module: means any or all Module, connected to the Software so +that they both execute in the same address space. + +GNU GPL: means the GNU General Public License version 2 or any +subsequent version, as published by the Free Software Foundation Inc. + +Parties: mean both the Licensee and the Licensor. + +These expressions may be used both in singular and plural form. + + + Article 2 - PURPOSE + +The purpose of the Agreement is the grant by the Licensor to the +Licensee of a non-exclusive, transferable and worldwide license for the +Software as set forth in Article 5 hereinafter for the whole term of the +protection granted by the rights over said Software. + + + Article 3 - ACCEPTANCE + +3.1 The Licensee shall be deemed as having accepted the terms and +conditions of this Agreement upon the occurrence of the first of the +following events: + + * (i) loading the Software by any or all means, notably, by + downloading from a remote server, or by loading from a physical + medium; + * (ii) the first time the Licensee exercises any of the rights + granted hereunder. + +3.2 One copy of the Agreement, containing a notice relating to the +characteristics of the Software, to the limited warranty, and to the +fact that its use is restricted to experienced users has been provided +to the Licensee prior to its acceptance as set forth in Article 3.1 +hereinabove, and the Licensee hereby acknowledges that it has read and +understood it. + + + Article 4 - EFFECTIVE DATE AND TERM + + + 4.1 EFFECTIVE DATE + +The Agreement shall become effective on the date when it is accepted by +the Licensee as set forth in Article 3.1. + + + 4.2 TERM + +The Agreement shall remain in force for the entire legal term of +protection of the economic rights over the Software. + + + Article 5 - SCOPE OF RIGHTS GRANTED + +The Licensor hereby grants to the Licensee, who accepts, the following +rights over the Software for any or all use, and for the term of the +Agreement, on the basis of the terms and conditions set forth hereinafter. + +Besides, if the Licensor owns or comes to own one or more patents +protecting all or part of the functions of the Software or of its +components, the Licensor undertakes not to enforce the rights granted by +these patents against successive Licensees using, exploiting or +modifying the Software. If these patents are transferred, the Licensor +undertakes to have the transferees subscribe to the obligations set +forth in this paragraph. + + + 5.1 RIGHT OF USE + +The Licensee is authorized to use the Software, without any limitation +as to its fields of application, with it being hereinafter specified +that this comprises: + + 1. permanent or temporary reproduction of all or part of the Software + by any or all means and in any or all form. + + 2. loading, displaying, running, or storing the Software on any or + all medium. + + 3. entitlement to observe, study or test its operation so as to + determine the ideas and principles behind any or all constituent + elements of said Software. This shall apply when the Licensee + carries out any or all loading, displaying, running, transmission + or storage operation as regards the Software, that it is entitled + to carry out hereunder. + + + 5.2 ENTITLEMENT TO MAKE CONTRIBUTIONS + +The right to make Contributions includes the right to translate, adapt, +arrange, or make any or all modifications to the Software, and the right +to reproduce the resulting software. + +The Licensee is authorized to make any or all Contributions to the +Software provided that it includes an explicit notice that it is the +author of said Contribution and indicates the date of the creation thereof. + + + 5.3 RIGHT OF DISTRIBUTION + +In particular, the right of distribution includes the right to publish, +transmit and communicate the Software to the general public on any or +all medium, and by any or all means, and the right to market, either in +consideration of a fee, or free of charge, one or more copies of the +Software by any means. + +The Licensee is further authorized to distribute copies of the modified +or unmodified Software to third parties according to the terms and +conditions set forth hereinafter. + + + 5.3.1 DISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION + +The Licensee is authorized to distribute true copies of the Software in +Source Code or Object Code form, provided that said distribution +complies with all the provisions of the Agreement and is accompanied by: + + 1. a copy of the Agreement, + + 2. a notice relating to the limitation of both the Licensor's + warranty and liability as set forth in Articles 8 and 9, + +and that, in the event that only the Object Code of the Software is +redistributed, the Licensee allows future Licensees unhindered access to +the full Source Code of the Software by indicating how to access it, it +being understood that the additional cost of acquiring the Source Code +shall not exceed the cost of transferring the data. + + + 5.3.2 DISTRIBUTION OF MODIFIED SOFTWARE + +When the Licensee makes a Contribution to the Software, the terms and +conditions for the distribution of the resulting Modified Software +become subject to all the provisions of this Agreement. + +The Licensee is authorized to distribute the Modified Software, in +source code or object code form, provided that said distribution +complies with all the provisions of the Agreement and is accompanied by: + + 1. a copy of the Agreement, + + 2. a notice relating to the limitation of both the Licensor's + warranty and liability as set forth in Articles 8 and 9, + +and that, in the event that only the object code of the Modified +Software is redistributed, the Licensee allows future Licensees +unhindered access to the full source code of the Modified Software by +indicating how to access it, it being understood that the additional +cost of acquiring the source code shall not exceed the cost of +transferring the data. + + + 5.3.3 DISTRIBUTION OF EXTERNAL MODULES + +When the Licensee has developed an External Module, the terms and +conditions of this Agreement do not apply to said External Module, that +may be distributed under a separate license agreement. + + + 5.3.4 COMPATIBILITY WITH THE GNU GPL + +The Licensee can include a code that is subject to the provisions of one +of the versions of the GNU GPL in the Modified or unmodified Software, +and distribute that entire code under the terms of the same version of +the GNU GPL. + +The Licensee can include the Modified or unmodified Software in a code +that is subject to the provisions of one of the versions of the GNU GPL, +and distribute that entire code under the terms of the same version of +the GNU GPL. + + + Article 6 - INTELLECTUAL PROPERTY + + + 6.1 OVER THE INITIAL SOFTWARE + +The Holder owns the economic rights over the Initial Software. Any or +all use of the Initial Software is subject to compliance with the terms +and conditions under which the Holder has elected to distribute its work +and no one shall be entitled to modify the terms and conditions for the +distribution of said Initial Software. + +The Holder undertakes that the Initial Software will remain ruled at +least by this Agreement, for the duration set forth in Article 4.2. + + + 6.2 OVER THE CONTRIBUTIONS + +The Licensee who develops a Contribution is the owner of the +intellectual property rights over this Contribution as defined by +applicable law. + + + 6.3 OVER THE EXTERNAL MODULES + +The Licensee who develops an External Module is the owner of the +intellectual property rights over this External Module as defined by +applicable law and is free to choose the type of agreement that shall +govern its distribution. + + + 6.4 JOINT PROVISIONS + +The Licensee expressly undertakes: + + 1. not to remove, or modify, in any manner, the intellectual property + notices attached to the Software; + + 2. to reproduce said notices, in an identical manner, in the copies + of the Software modified or not. + +The Licensee undertakes not to directly or indirectly infringe the +intellectual property rights of the Holder and/or Contributors on the +Software and to take, where applicable, vis-�-vis its staff, any and all +measures required to ensure respect of said intellectual property rights +of the Holder and/or Contributors. + + + Article 7 - RELATED SERVICES + +7.1 Under no circumstances shall the Agreement oblige the Licensor to +provide technical assistance or maintenance services for the Software. + +However, the Licensor is entitled to offer this type of services. The +terms and conditions of such technical assistance, and/or such +maintenance, shall be set forth in a separate instrument. Only the +Licensor offering said maintenance and/or technical assistance services +shall incur liability therefor. + +7.2 Similarly, any Licensor is entitled to offer to its licensees, under +its sole responsibility, a warranty, that shall only be binding upon +itself, for the redistribution of the Software and/or the Modified +Software, under terms and conditions that it is free to decide. Said +warranty, and the financial terms and conditions of its application, +shall be subject of a separate instrument executed between the Licensor +and the Licensee. + + + Article 8 - LIABILITY + +8.1 Subject to the provisions of Article 8.2, the Licensee shall be +entitled to claim compensation for any direct loss it may have suffered +from the Software as a result of a fault on the part of the relevant +Licensor, subject to providing evidence thereof. + +8.2 The Licensor's liability is limited to the commitments made under +this Agreement and shall not be incurred as a result of in particular: +(i) loss due the Licensee's total or partial failure to fulfill its +obligations, (ii) direct or consequential loss that is suffered by the +Licensee due to the use or performance of the Software, and (iii) more +generally, any consequential loss. In particular the Parties expressly +agree that any or all pecuniary or business loss (i.e. loss of data, +loss of profits, operating loss, loss of customers or orders, +opportunity cost, any disturbance to business activities) or any or all +legal proceedings instituted against the Licensee by a third party, +shall constitute consequential loss and shall not provide entitlement to +any or all compensation from the Licensor. + + + Article 9 - WARRANTY + +9.1 The Licensee acknowledges that the scientific and technical +state-of-the-art when the Software was distributed did not enable all +possible uses to be tested and verified, nor for the presence of +possible defects to be detected. In this respect, the Licensee's +attention has been drawn to the risks associated with loading, using, +modifying and/or developing and reproducing the Software which are +reserved for experienced users. + +The Licensee shall be responsible for verifying, by any or all means, +the suitability of the product for its requirements, its good working +order, and for ensuring that it shall not cause damage to either persons +or properties. + +9.2 The Licensor hereby represents, in good faith, that it is entitled +to grant all the rights over the Software (including in particular the +rights set forth in Article 5). + +9.3 The Licensee acknowledges that the Software is supplied "as is" by +the Licensor without any other express or tacit warranty, other than +that provided for in Article 9.2 and, in particular, without any warranty +as to its commercial value, its secured, safe, innovative or relevant +nature. + +Specifically, the Licensor does not warrant that the Software is free +from any error, that it will operate without interruption, that it will +be compatible with the Licensee's own equipment and software +configuration, nor that it will meet the Licensee's requirements. + +9.4 The Licensor does not either expressly or tacitly warrant that the +Software does not infringe any third party intellectual property right +relating to a patent, software or any other property right. Therefore, +the Licensor disclaims any and all liability towards the Licensee +arising out of any or all proceedings for infringement that may be +instituted in respect of the use, modification and redistribution of the +Software. Nevertheless, should such proceedings be instituted against +the Licensee, the Licensor shall provide it with technical and legal +assistance for its defense. Such technical and legal assistance shall be +decided on a case-by-case basis between the relevant Licensor and the +Licensee pursuant to a memorandum of understanding. The Licensor +disclaims any and all liability as regards the Licensee's use of the +name of the Software. No warranty is given as regards the existence of +prior rights over the name of the Software or as regards the existence +of a trademark. + + + Article 10 - TERMINATION + +10.1 In the event of a breach by the Licensee of its obligations +hereunder, the Licensor may automatically terminate this Agreement +thirty (30) days after notice has been sent to the Licensee and has +remained ineffective. + +10.2 A Licensee whose Agreement is terminated shall no longer be +authorized to use, modify or distribute the Software. However, any +licenses that it may have granted prior to termination of the Agreement +shall remain valid subject to their having been granted in compliance +with the terms and conditions hereof. + + + Article 11 - MISCELLANEOUS + + + 11.1 EXCUSABLE EVENTS + +Neither Party shall be liable for any or all delay, or failure to +perform the Agreement, that may be attributable to an event of force +majeure, an act of God or an outside cause, such as defective +functioning or interruptions of the electricity or telecommunications +networks, network paralysis following a virus attack, intervention by +government authorities, natural disasters, water damage, earthquakes, +fire, explosions, strikes and labor unrest, war, etc. + +11.2 Any failure by either Party, on one or more occasions, to invoke +one or more of the provisions hereof, shall under no circumstances be +interpreted as being a waiver by the interested Party of its right to +invoke said provision(s) subsequently. + +11.3 The Agreement cancels and replaces any or all previous agreements, +whether written or oral, between the Parties and having the same +purpose, and constitutes the entirety of the agreement between said +Parties concerning said purpose. No supplement or modification to the +terms and conditions hereof shall be effective as between the Parties +unless it is made in writing and signed by their duly authorized +representatives. + +11.4 In the event that one or more of the provisions hereof were to +conflict with a current or future applicable act or legislative text, +said act or legislative text shall prevail, and the Parties shall make +the necessary amendments so as to comply with said act or legislative +text. All other provisions shall remain effective. Similarly, invalidity +of a provision of the Agreement, for any reason whatsoever, shall not +cause the Agreement as a whole to be invalid. + + + 11.5 LANGUAGE + +The Agreement is drafted in both French and English and both versions +are deemed authentic. + + + Article 12 - NEW VERSIONS OF THE AGREEMENT + +12.1 Any person is authorized to duplicate and distribute copies of this +Agreement. + +12.2 So as to ensure coherence, the wording of this Agreement is +protected and may only be modified by the authors of the License, who +reserve the right to periodically publish updates or new versions of the +Agreement, each with a separate number. These subsequent versions may +address new issues encountered by Free Software. + +12.3 Any Software distributed under a given version of the Agreement may +only be subsequently distributed under the same version of the Agreement +or a subsequent version, subject to the provisions of Article 5.3.4. + + + Article 13 - GOVERNING LAW AND JURISDICTION + +13.1 The Agreement is governed by French law. The Parties agree to +endeavor to seek an amicable solution to any disagreements or disputes +that may arise during the performance of the Agreement. + +13.2 Failing an amicable solution within two (2) months as from their +occurrence, and unless emergency proceedings are necessary, the +disagreements or disputes shall be referred to the Paris Courts having +jurisdiction, by the more diligent Party. + + +Version 2.0 dated 2006-09-05. diff --git a/NEMO_4.0.4_surge/README.rst b/NEMO_4.0.4_surge/README.rst new file mode 100644 index 0000000..3d6f72b --- /dev/null +++ b/NEMO_4.0.4_surge/README.rst @@ -0,0 +1,99 @@ +.. todo:: + + + +NEMO_ for *Nucleus for European Modelling of the Ocean* is a state-of-the-art modelling framework for +research activities and forecasting services in ocean and climate sciences, +developed in a sustainable way by a European consortium since 2008. + +.. contents:: + :local: + +Overview +======== + +The NEMO ocean model has 3 major components: + +- |OCE| models the ocean {thermo}dynamics and solves the primitive equations + (:file:`./src/OCE`) +- |ICE| simulates sea-ice {thermo}dynamics, brine inclusions and + subgrid-scale thickness variations (:file:`./src/ICE`) +- |MBG| models the {on,off}line oceanic tracers transport and biogeochemical processes + (:file:`./src/TOP`) + +These physical core engines are described in +their respective `reference publications <#project-documentation>`_ that +must be cited for any work related to their use (see :doc:`cite`). + +Assets and solutions +==================== + +Not only does the NEMO framework model the ocean circulation, +it offers various features to enable + +- Create :doc:`embedded zooms` seamlessly thanks to 2-way nesting package AGRIF_. +- Opportunity to integrate an :doc:`external biogeochemistry model` +- Versatile :doc:`data assimilation` +- Generation of :doc:`diagnostics` through effective XIOS_ system +- Roll-out Earth system modeling with :doc:`coupling interface` based on OASIS_ + +Several :doc:`built-in configurations` are provided to +evaluate the skills and performances of the model which +can be used as templates for setting up a new configurations (:file:`./cfgs`). + +The user can also checkout available :doc:`idealized test cases` that +address specific physical processes (:file:`./tests`). + +A set of :doc:`utilities ` is also provided to {pre,post}process your data (:file:`./tools`). + +Project documentation +===================== + +A walkthrough tutorial illustrates how to get code dependencies, compile and execute NEMO +(:file:`./INSTALL.rst`). + +Reference manuals and quick start guide can be build from source and +exported to HTML or PDF formats (:file:`./doc`) or +downloaded directly from the :forge:`development platform`. + +============ ================== =================== + Component Reference Manual Quick Start Guide +============ ================== =================== + |NEMO-OCE| |DOI man OCE|_ |DOI qsg| + |NEMO-ICE| |DOI man ICE| + |NEMO-MBG| |DOI man MBG| +============ ================== =================== + +Since 2014 the project has a `Special Issue`_ in the open-access journal +Geoscientific Model Development (GMD) from the European Geosciences Union (EGU_). +The main scope is to collect relevant manuscripts covering various topics and +to provide a single portal to assess the model potential and evolution. + +Used by a wide audience, +numerous :website:`associated projects` have been carried out and +extensive :website:`bibliography` published. + +Development board +================= + +The NEMO Consortium pulling together 5 European institutes +(CMCC_, CNRS_, MOI_, `Met Office`_ and NERC_) plans the sustainable development in order to +keep a reliable evolving framework since 2008. + +It defines the |DOI dev stgy|_ that is implemented by the System Team on a yearly basis +in order to release a new version almost every four years. + +When the need arises, :forge:`working groups` are created or resumed to +gather the community expertise for advising on the development activities. + +.. |DOI dev stgy| replace:: multi-year development strategy + +Disclaimer +========== + +The NEMO source code is freely available and distributed under +:download:`CeCILL v2.0 license <../../../LICENSE>` (GNU GPL compatible). + +You can use, modify and/or redistribute the software under its terms, +but users are provided only with a limited warranty and the software's authors and +the successive licensor's have only limited liability. diff --git a/NEMO_4.0.4_surge/REFERENCES.bib b/NEMO_4.0.4_surge/REFERENCES.bib new file mode 100644 index 0000000..bb87f26 --- /dev/null +++ b/NEMO_4.0.4_surge/REFERENCES.bib @@ -0,0 +1,46 @@ +@manual{NEMO_man, + title="NEMO ocean engine", + author="NEMO System Team", + series="Scientific Notes of Climate Modelling Center", + number="27", + institution="Institut Pierre-Simon Laplace (IPSL)", + publisher="Zenodo", + doi="10.5281/zenodo.1464816", +} +% edition="", +% year="" + +@manual{SI3_man, + title="Sea Ice modelling Integrated Initiative (SI$^3$) -- The NEMO Sea Ice engine", + author="NEMO Sea Ice Working Group", + series="Scientific Notes of Climate Modelling Center", + number="31", + institution="Institut Pierre-Simon Laplace (IPSL)", + publisher="Zenodo", + doi="10.5281/zenodo.1471689", +} +% edition="", +% year="" + +@manual{TOP_man, + title="Tracers in Ocean Paradigm (TOP) -- The NEMO Tracers engine", + author="NEMO TOP Working Group", + series="Scientific Notes of Climate Modelling Center", + number="28", + institution="Institut Pierre-Simon Laplace (IPSL)", + publisher="Zenodo", + doi="10.5281/zenodo.1471700", +} +% edition="", +% year="" + +@article{TAM_pub, + author = "Vidard, A. and Bouttier, P.-A. and Vigilant, F.", + title = "NEMOTAM: Tangent and Adjoint Models for the ocean modelling platform NEMO", + journal = "Geoscientific Model Development", + volume = "8", + year = "2015", + number = "4", + pages = "1245--1257", + doi = "10.5194/gmd-8-1245-2015" +} diff --git a/NEMO_4.0.4_surge/arch/CMCC/arch-gfortran_athena_xios.fcm b/NEMO_4.0.4_surge/arch/CMCC/arch-gfortran_athena_xios.fcm new file mode 100644 index 0000000..356559c --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CMCC/arch-gfortran_athena_xios.fcm @@ -0,0 +1,62 @@ +# mpi gfortran compiler options for ATHENA using XIOS parallel writer server +# +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# + +%NCDF_HOME /users/home/ans040/local +%HDF5_HOME /users/home/ans040/local +%XIOS_HOME /users/home/ans040/SOFTWARE/XIOS/trunk + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib + +%HDF5_INC -I%HDF5_HOME/include +%HDF5_LIB -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 + +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios + +%CPP cpp +%FC mpif90 +%FCFLAGS -fdefault-real-8 -fno-second-underscore -Dgfortran -ffree-line-length-none +%FFLAGS %FCFLAGS +%LD %FC +%LDFLAGS +%FPPFLAGS -x f77-cpp-input +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC %HDF5_INC +%USER_LIB %XIOS_LIB %NCDF_LIB %HDF5_LIB -lnetcdff -lnetcdf -lstdc++ -lz -lcurl -lgpfs + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena.fcm b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena.fcm new file mode 100644 index 0000000..eb6fec2 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena.fcm @@ -0,0 +1,35 @@ +# 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC + + +%NCDF_INC -I${NETCDF}/include +%NCDF_LIB -L${NETCDF}/lib -lnetcdf -lnetcdff +%CPP cpp +%FC mpiifort +%FCFLAGS -r8 -O3 -xHost -fp-model source -traceback +%FFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB +%CC icc +%CFLAGS -O0 + diff --git a/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_debug.fcm b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_debug.fcm new file mode 100644 index 0000000..3b04e5b --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_debug.fcm @@ -0,0 +1,35 @@ +# 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC + + +%NCDF_INC -I$NETCDF/include +%NCDF_LIB -L$NETCDF/lib -lnetcdf -lnetcdff +%CPP cpp +%FC mpiifort +%FCFLAGS -fpe0 -g -r8 -O1 -xHost -fp-model source -traceback +%FFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB +%CC icc +%CFLAGS -O0 + diff --git a/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_tools.fcm b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_tools.fcm new file mode 100644 index 0000000..eac9f26 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_tools.fcm @@ -0,0 +1,35 @@ +# 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC + + +%NCDF_INC -I$NETCDF/include +%NCDF_LIB -L$NETCDF/lib -lnetcdf -lnetcdff +%CPP cpp +%FC ifort +%FCFLAGS -r8 -O3 -xHost -fp-model source -traceback +%FFLAGS %FCFLAGS +%LD ifort +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB +%CC icc +%CFLAGS -O0 + diff --git a/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_xios.fcm b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_xios.fcm new file mode 100644 index 0000000..b18dfc4 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CMCC/arch-ifort_athena_xios.fcm @@ -0,0 +1,62 @@ +# mpi ifort compiler options for ATHENA using XIOS parallel writer server +# +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# + +# required modules +# module load INTEL/intel_xe_2013 NETCDF/netcdf-4.3_parallel NETCDF/parallel-netcdf-1.7.0 HDF5/hdf5-1.8.11_parallel + +# NETCDF and PNETCDF should be set automatically when loading modules. +# The following environment variables must be set by the user. +#export XIOS=/users/home/models/nemo/xios +#export HDF5=/users/home/opt/hdf5/hdf5-1.8.11_parallel + +%NCDF_INC -I${NETCDF}/include -I${PNETCDF}/include +%NCDF_LIB -L${NETCDF}/lib -lnetcdff -lnetcdf -L${PNETCDF}/lib -lpnetcdf +%HDF5_INC -I${HDF5}/include +%HDF5_LIB -L${HDF5}/lib -lhdf5_hl -lhdf5 +%XIOS_INC -I${XIOS}/inc +%XIOS_LIB -L${XIOS}/lib -lxios +%CPP cpp +%FC mpiifort +%FCFLAGS -r8 -O3 -xHost -fp-model source -traceback +%FFLAGS %FCFLAGS +%LD mpiifort +%FPPFLAGS -P -C -traditional +%LDFLAGS -lstdc++ -lz -lgpfs -lcurl +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC %HDF5_INC +%USER_LIB %XIOS_LIB %NCDF_LIB %HDF5_LIB +%CC icc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA.fcm new file mode 100644 index 0000000..dd57e97 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA.fcm @@ -0,0 +1,60 @@ +# Ada IBM x3750 at french IDRIS, http://www.idris.fr/ada/ada-hw-ada.html +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /smplocal/pub/NetCDF/4.1.3/mpi +%HDF5_HOME /smplocal/pub/HDF5/1.8.9/par +%XIOS_HOME $WORKDIR/XIOS +####%OASIS_HOME $WORKDIR/oasis3-mct/BLD +%OASIS_HOME /not/defined + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -Bstatic -lnetcdff -lnetcdf -Bdynamic -L%HDF5_HOME/lib -Bstatic -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -Bdynamic -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpiifort -c -cpp +%FCFLAGS -DCPP_PARA -i4 -r8 -O3 -axAVX,SSE4.2 -fp-model precise +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC icc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA_DEBUG.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA_DEBUG.fcm new file mode 100644 index 0000000..2ac5e70 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA_DEBUG.fcm @@ -0,0 +1,59 @@ +# Ada IBM x3750 at french IDRIS, http://www.idris.fr/ada/ada-hw-ada.html +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /smplocal/pub/NetCDF/4.1.3/mpi +%HDF5_HOME /smplocal/pub/HDF5/1.8.9/par +%XIOS_HOME $WORKDIR/XIOS +%OASIS_HOME /not/yet/defined + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -Bstatic -lnetcdff -lnetcdf -Bdynamic -L%HDF5_HOME/lib -Bstatic -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -Bdynamic -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpiifort -c -cpp +%FCFLAGS -DCPP_PARA -i4 -r8 -g -O0 -debug all -traceback -fp-model precise -ftrapuv -fpe0 +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC icc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA_O0.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA_O0.fcm new file mode 100644 index 0000000..489b8f9 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_ADA_O0.fcm @@ -0,0 +1,54 @@ +# Ada IBM x3750 at french IDRIS, http://www.idris.fr/ada/ada-hw-ada.html +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /smplocal/pub/NetCDF/4.1.3/mpi +%HDF5_HOME /smplocal/pub/HDF5/1.8.9/par +%XIOS_HOME $WORKDIR/XIOS2 +%OASIS_HOME /not/yet/defined + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -Bstatic -lnetcdff -lnetcdf -Bdynamic -L%HDF5_HOME/lib -Bstatic -lhdf5hl_fortran -lhdf5_hl -lhdf5_fortran -lhdf5 -Bdynamic -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpiifort -c -cpp +%FCFLAGS -DCPP_PARA -i4 -r8 -O0 -xAVX -fp-model precise +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_IRENE.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_IRENE.fcm new file mode 100644 index 0000000..d24e954 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_IRENE.fcm @@ -0,0 +1,58 @@ +# Irene BULL at TGCC, http://www-hpc.cea.fr/en/complexe/tgcc-Irene.htm +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%XIOS_HOME $CCCWORKDIR/xios-2.5 +%OASIS_HOME $CCCWORKDIR/now/models/oa3mct + +%NCDF_INC -I$NETCDFFORTRAN_INCDIR -I$NETCDF_INCDIR +%NCDF_LIB -L$NETCDFFORTRAN_LIBDIR -lnetcdff -L$NETCDF_LIBDIR -lnetcdf -L$HDF5_LIBDIR -lhdf5_hl -lhdf5 -lz -lcurl + +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 -O3 -fp-model strict -xCORE-AVX512 -fno-alias +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_IRENE_DEBUG.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_IRENE_DEBUG.fcm new file mode 100644 index 0000000..25b50f6 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_IRENE_DEBUG.fcm @@ -0,0 +1,58 @@ +# Irene BULL at TGCC, http://www-hpc.cea.fr/en/complexe/tgcc-Irene.htm +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%XIOS_HOME $CCCWORKDIR/xios-2.5 +%OASIS_HOME $CCCWORKDIR/now/models/oa3mct + +%NCDF_INC -I$NETCDFFORTRAN_INCDIR -I$NETCDF_INCDIR +%NCDF_LIB -L$NETCDFFORTRAN_LIBDIR -lnetcdff -L$NETCDF_LIBDIR -lnetcdf -L$HDF5_LIBDIR -lhdf5_hl -lhdf5 -lz -lcurl + +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 -g -O0 -debug all -traceback -fp-model strict -ftrapuv -fpe0 -check bounds +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_JEANZAY.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_JEANZAY.fcm new file mode 100644 index 0000000..cb2137c --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_JEANZAY.fcm @@ -0,0 +1,63 @@ +# Jean-Zay HPE at IDRIS, http://www.idris.fr/jean-zay +# +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +#--------------------------------------------------------------------------------------------- +#--------------------------------------------------------------------------------------------- +# All NETCDF and HDF paths are empty as they are automatically defined through environment +# variables by the load of modules +#--------------------------------------------------------------------------------------------- +#--------------------------------------------------------------------------------------------- +# +# +%XIOS_HOME $WORK/xios-2.5 +%OASIS_HOME + +%NCDF_INC +%NCDF_LIB -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz -lcurl +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpiifort -c -cpp +%FCFLAGS -i4 -r8 -O3 -fp-model strict -xCORE-AVX512 -fno-alias +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS +%FPPFLAGS -P -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/CNRS/arch-X64_JEANZAY_DEBUG.fcm b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_JEANZAY_DEBUG.fcm new file mode 100644 index 0000000..fbc7ff5 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/CNRS/arch-X64_JEANZAY_DEBUG.fcm @@ -0,0 +1,63 @@ +# Jean-Zay HPE at IDRIS, http://www.idris.fr/jean-zay +# +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +#--------------------------------------------------------------------------------------------- +#--------------------------------------------------------------------------------------------- +# All NETCDF and HDF paths are empty as they are automatically defined through environment +# variables by the load of modules +#--------------------------------------------------------------------------------------------- +#--------------------------------------------------------------------------------------------- +# +# +%XIOS_HOME $WORK/xios-2.5 +%OASIS_HOME + +%NCDF_INC +%NCDF_LIB -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz -lcurl +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpiifort -c -cpp +%FCFLAGS -i4 -r8 -g -O0 -debug all -traceback -fp-model strict -ftrapuv -check bounds -fpe-all=0 -ftz +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS +%FPPFLAGS -P -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/INGV/arch-IBM_EKMAN_INGV.fcm b/NEMO_4.0.4_surge/arch/INGV/arch-IBM_EKMAN_INGV.fcm new file mode 100644 index 0000000..fae77f4 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/INGV/arch-IBM_EKMAN_INGV.fcm @@ -0,0 +1,37 @@ +# EKMAN IBM Intel Sandy Bridge at INGV +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# XIOS_ROOT root directory containing lib for XIOS +# MPI_INTEL directory for intel mpi 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC + +%NCDF_INC -I/srv/lib/netcdf-x/include +%NCDF_LIB -L/srv/lib/netcdf-x/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lcurl -lstdc++ +%XIOS_ROOT /home/delrosso/XIOS_1.0/xios-1.0 +%MPI_INTEL -I/srv/intel/impi/4.1.0.024/include +%CPP cpp +%FC mpiifort +%FCFLAGS -r8 -O1 -g -traceback -fp-model precise +%FFLAGS %FCFLAGS +%LD mpiifort +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC -I%XIOS_ROOT/inc %NCDF_INC %MPI_INTEL -I/srv/lib/zlib-last/include +%USER_LIB -L%XIOS_ROOT/lib -lxios %NCDF_LIB -L/srv/lib/zlib-last/lib -lz +%CC icc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/MERCATOR/arch-openmpi_KARA_MERCATOR_XIOS.fcm b/NEMO_4.0.4_surge/arch/MERCATOR/arch-openmpi_KARA_MERCATOR_XIOS.fcm new file mode 100644 index 0000000..b83ed3c --- /dev/null +++ b/NEMO_4.0.4_surge/arch/MERCATOR/arch-openmpi_KARA_MERCATOR_XIOS.fcm @@ -0,0 +1,39 @@ +# 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# debug: -g -check bounds -check uninit -check pointers -traceback +# #-xAVX +# +%NCDF_INC -I$NETCDF_INC +%NCDF_LIB -L$NETCDF_LIB -lnetcdff -lnetcdf -L$HDF5_LIB -lhdf5_hl -lhdf5 -lz + +%CPP cpp +%FC mpif90 -fpp +# norep 156 %FCFLAGS -i4 -r8 -O3 -fp-model precise +# norep 156 %FCFLAGS -i4 -r8 -O2 -fp-model precise +%FCFLAGS -i4 -r8 -O0 -fp-model precise +%FFLAGS %FCFLAGS +%LD mpif90 +%FPPFLAGS -P -traditional +%LDFLAGS -O2 +%AR ar +%ARFLAGS -rs +%MK gmake +%USER_INC -I$XIOS_INC %NCDF_INC +%USER_LIB -L$XIOS_LIB -lxios %NCDF_LIB -lstdc++ + +%CC mpicc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-ALTIX_NAUTILUS_MPT.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-ALTIX_NAUTILUS_MPT.fcm new file mode 100644 index 0000000..10d53a4 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-ALTIX_NAUTILUS_MPT.fcm @@ -0,0 +1,64 @@ +# ifort compiler options for NOCS ALTIX cluster nautilus using NetCDF4 libraries +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%HDF5_HOME /fibre/omfman/NETCDF_PAR +%NCDF_HOME /fibre/omfman/NETCDF_PAR +%XIOS_HOME /fibre/omfman/XIOS +%OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +# Note use of -Bstatic because the library root directories may not be accessible to the back-end compute nodes +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -Bstatic -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -Bdynamic -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC ifort +%FCFLAGS -r8 -O3 -fp-model precise -xT -ip -vec-report0 +%FFLAGS -r8 -O3 -fp-model precise -xT -ip -vec-report0 +%LD ifort +%FPPFLAGS -P -C -traditional +%LDFLAGS -lmpi -lstdc++ -lcurl +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +# - if debugging use these flags +#FCFLAGS -g -traceback -r8 -O0 -xT -ip -vec-report0 +#FFLAGS -g -traceback -r8 -O0 -xT -ip -vec-report0 + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-THALASSA.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-THALASSA.fcm new file mode 100644 index 0000000..937f6b4 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-THALASSA.fcm @@ -0,0 +1,68 @@ +# generic gfortran compiler options for OSX installed with macport, http://www.macports.org/ +# +# port packages needed: +# sudo port install openmpi +gcc48 +# sudo port install hdf5-18 +cxx +fortran +openmpi (I'am not sure cxx is needed) +# sudo port install netcdf +openmpi +# sudo port install netcdf-fortran +openmpi +# sudo port install netcdf-cxx +openmpi (I'am not sure it is needed) +# sudo port install p5-uri +# add to your PATH /opt/local/lib/openmpi/bin so that mpif90 is properly known +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /nerc/packages/netcdf/4.3.3.1 +%HDF5_HOME /nerc/packages/hdf5/1.8.15 +%XIOS_HOME /noc/msm/working/nemo/acc/XIOS/xios-1.0 +%OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC +%OASIS_LIB + +%CPP cpp +%FC mpif90 +%FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none +%FFLAGS %FCFLAGS +%LD %FC +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK make +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-X64_MOBILIS.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-X64_MOBILIS.fcm new file mode 100644 index 0000000..d046673 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-X64_MOBILIS.fcm @@ -0,0 +1,72 @@ +# Mobilis - ClusterVision X86_64 cluster at NOCS +#--------------------------------------------------------------------- +# REMEMBER TO LOAD THE CORRECT ENVIRONMENT BEFORE INVOKING makenemo # +#--------------------------------------------------------------------- +# +# Works with nemo-PrgEnv modules on Mobilis +# module use /home/acc/MyMods +# and either: +# +# module load nemo-PrgEnv/4.0 +# or +# module load nemo-PrgEnv/3.6 +# +#--------------------------------------------------------------------- +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - fcm variables are starting with a % (and not a $) +# - unix variables "$..." are accepted and will be evaluated before calling fcm. +# - The $ variables in this arch file are set by the nemo-PrgEnv module (see top) +# +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME $XIO_HOME +%OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdf -lnetcdff -lnetcdf -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 -lhdf5 -lcurl +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC +%OASIS_LIB + +%CPP cpp +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 -O3 -fp-model source -xAVX +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC icc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Cray_4.2.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Cray_4.2.fcm new file mode 100644 index 0000000..85e12ce --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Cray_4.2.fcm @@ -0,0 +1,63 @@ +# compiler options for Archer CRAY XC-30 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_xios is activated) +# XIOS_LIB xios library (taken into accound only if key_xios is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +# Known to work with: module load cray-mpich/8.1.23 ; module load cray-hdf5-parallel/1.12.2.1 ; module load cray-netcdf-hdf5parallel/4.9.0.1 +%NCDF_HOME ${NETCDF_DIR} +%HDF5_HOME ${HDF5_DIR} +%XIOS_HOME /work/n01/shared/nemo/XIOS2_Cray +#OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +#OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +#OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp -Dkey_nosignedzero +%FC ftn +%FCFLAGS -em -s integer32 -s real64 -O1,vector0 -hflex_mp=intolerant -N1023 -M878 +%FFLAGS -em -s integer32 -s real64 -O1,vector0 -hflex_mp=intolerant -N1023 -M878 +%LD CC -Wl,"--allow-multiple-definition" +%FPPFLAGS -P -traditional +%LDFLAGS -lmpifort_cray +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB +#USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +#USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc -Wl,"--allow-multiple-definition" +%CFLAGS -O0 +bld::tool::fc_modsearch -J diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Gnu_4.2.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Gnu_4.2.fcm new file mode 100644 index 0000000..5f3df3f --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Gnu_4.2.fcm @@ -0,0 +1,62 @@ +# compiler options for Archer CRAY XC-30 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_xios is activated) +# XIOS_LIB xios library (taken into accound only if key_xios is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME ${NETCDF_DIR} +%HDF5_HOME ${HDF5_DIR} +%XIOS_HOME /work/n01/shared/nemo/XIOS2_Gnu +#OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +#OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +#OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp -Dkey_nosignedzero +%FC ftn +%FCFLAGS -O2 -cpp -ffp-contract=off -fallow-argument-mismatch -fdefault-real-8 -fcray-pointer -ffree-line-length-none +%FFLAGS -O2 -cpp -ffp-contract=off -fallow-argument-mismatch -fdefault-real-8 -fcray-pointer -ffree-line-length-none +%LD CC +%FPPFLAGS -P -traditional +%LDFLAGS -lmpichf90 +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB +#USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +#USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc -Wl,"--allow-multiple-definition" +%CFLAGS -O2 -Wl,"--allow-multiple-definition" +bld::tool::fc_modsearch -J diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-XC_ARCHER.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-XC_ARCHER.fcm new file mode 100644 index 0000000..519063a --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-XC_ARCHER.fcm @@ -0,0 +1,63 @@ +# compiler options for Archer CRAY XC-30 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME /work/n01/n01/acc/XIOS_r474 +#OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +#OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +#OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC ftn +#FCFLAGS -em -s integer32 -s real64 -O3 +#FFLAGS -em -s integer32 -s real64 -O3 +%FCFLAGS -em -s integer32 -s real64 -O0 -e0 -eZ +%FFLAGS -em -s integer32 -s real64 -O0 -e0 -eZ +%LD CC -Wl,"--allow-multiple-definition" +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB +#USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +#USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/NOC/arch-XC_ARCHER_INTEL.fcm b/NEMO_4.0.4_surge/arch/NOC/arch-XC_ARCHER_INTEL.fcm new file mode 100644 index 0000000..00f64f5 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/NOC/arch-XC_ARCHER_INTEL.fcm @@ -0,0 +1,61 @@ +# compiler options for Archer CRAY XC-30 (using intel compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME /work/n01/n01/acc/XIOS_r484 +#OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +#OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +#OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC ftn +%FCFLAGS -integer-size 32 -real-size 64 -O3 -fp-model source -zero -fpp -warn all +%FFLAGS -integer-size 32 -real-size 64 -O3 -fp-model source -zero -fpp -warn all +%LD CC -Wl,"--allow-multiple-definition" +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB +#USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +#USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/UKMO/arch-PW7_METO.fcm b/NEMO_4.0.4_surge/arch/UKMO/arch-PW7_METO.fcm new file mode 100644 index 0000000..d1bc356 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/UKMO/arch-PW7_METO.fcm @@ -0,0 +1,38 @@ +# IBM POWER7 UKMO +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# XIOS_INC XIOS include files +# XIOS_LIB XIOS 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC + + +%NCDF_INC -I/home/cr/ocean/hadcv/netcdf/4.1.3_par/include +%NCDF_LIB -L/home/cr/ocean/hadcv/netcdf/4.1.3_par/lib -lnetcdf -lnetcdff -lhdf5 -lhdf5_hl -lhdf5_fortran -lz +%XIOS_INC -I/home/cr/ocean/hadcv/xios_lib/par/r618/xios/inc +%XIOS_LIB -L/home/cr/ocean/hadcv/xios_lib/par/r618/xios/lib -lxios +%CPP cpp +%FC mpxlf90_r +%FCFLAGS -qrealsize=8 -qextname -qsuffix=f=f90 -qarch=pwr7 -qtune=pwr7 -g -O2 -qstrict -qinitauto=7FBFFFFF +%FFLAGS -qrealsize=8 -qextname -qsuffix=f=f90 -qarch=pwr7 -qtune=pwr7 -g -O2 -qstrict -qinitauto=7FBFFFFF +%LD mpCC_r +%LDFLAGS -lxlf90 -L/projects/um1/lib -lsig -O2 -L MASS +%FPPFLAGS -E -P -traditional -I/opt/ibmhpc/pecurrent/ppe.poe/include -I/usr/lpp/ppe.poe/include/thread64 +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB +%CC xlc +%CFLAGS -O -qcpluscmt diff --git a/NEMO_4.0.4_surge/arch/UKMO/arch-PW7_MONSOON.fcm b/NEMO_4.0.4_surge/arch/UKMO/arch-PW7_MONSOON.fcm new file mode 100644 index 0000000..b4738ab --- /dev/null +++ b/NEMO_4.0.4_surge/arch/UKMO/arch-PW7_MONSOON.fcm @@ -0,0 +1,38 @@ +# IBM POWER7 UKMO +# NCDF_INC netcdf include file +# NCDF_LIB netcdf library +# XIOS_INC XIOS include files +# XIOS_LIB XIOS 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 +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC + +%NCDF_INC -I/home/dcalve/netcdf/4.1.3_seq/include +%NCDF_LIB -L/home/dcalve/netcdf/4.1.3_seq/lib -lnetcdf -lnetcdff -lhdf5 -lhdf5_hl -lhdf5_fortran -lz +%XIOS_INC -I/home/dstork/xios_lib/par/r521/xios/inc +%XIOS_LIB -L/home/dstork/xios_lib/par/r521/xios/lib -lxios +%CPP cpp +%FC mpxlf90_r +%FCFLAGS -qrealsize=8 -qextname -qsuffix=f=f90 -qarch=pwr7 -qtune=pwr7 -g -O2 -qstrict -qinitauto=7FBFFFFF +%FFLAGS -qrealsize=8 -qextname -qarch=pwr7 -qtune=pwr7 -g -O2 -qstrict -qinitauto=7FBFFFFF -qfixed +%LD mpCC_r +%LDFLAGS -lxlf90 -L/projects/um1/lib -lsig -O2 -L MASS +%FPPFLAGS -E -P -traditional -I/opt/ibmhpc/pecurrent/ppe.poe/include -I/usr/lpp/ppe.poe/include/thread64 +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + +%CC xlc +%CFLAGS -O -qcpluscmt diff --git a/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO.fcm b/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO.fcm new file mode 100644 index 0000000..d4dcf57 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO.fcm @@ -0,0 +1,67 @@ +# compiler options for Archer CRAY XC-40 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +# This arch file depends on loading XIOS-PrgEnv/2.0/24708 + +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME $xios_path +%OASIS_HOME $prism_path + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz + +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios + +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIBDIR -L%OASIS_HOME/lib +%OASIS_LIB -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp -Dkey_nosignedzero +%FC ftn + +%FCFLAGS -em -s real64 -s integer32 -O2 -hflex_mp=intolerant -e0 -ez +%FFLAGS -em -s real64 -s integer32 -O2 -hflex_mp=intolerant -e0 -ez -Rb + +%LD ftn +%FPPFLAGS -P -E -traditional-cpp +%LDFLAGS -hbyteswapio +%AR ar +%ARFLAGS -r +%MK gmake + +%USER_INC %NCDF_INC %XIOS_INC %OASIS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB %OASIS_LIB %OASIS_LIBDIR + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO_IFORT.fcm b/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO_IFORT.fcm new file mode 100644 index 0000000..83470b6 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO_IFORT.fcm @@ -0,0 +1,66 @@ +# compiler options for Archer CRAY XC-40 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +# This arch file depends on loading XIOS-PrgEnv/2.0/24708 + +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME $xios_path +%OASIS_HOME $prism_path + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz + +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ + +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIBDIR -L%OASIS_HOME/lib +%OASIS_LIB -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC ftn + +%FCFLAGS -r8 -i4 -init=zero -init=arrays -traceback -debug minimal -debug inline-debug-info -O2 -fp-model consistent +%FFLAGS %FCFLAGS +%LD ftn +%FPPFLAGS -P -E -traditional-cpp +%LDFLAGS -hbyteswapio +%AR ar +%ARFLAGS -r +%MK gmake + +%USER_INC %NCDF_INC %XIOS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO_debug.fcm b/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO_debug.fcm new file mode 100644 index 0000000..e3805f8 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/UKMO/arch-XC40_METO_debug.fcm @@ -0,0 +1,66 @@ +# compiler options for Archer CRAY XC-40 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +# This arch file depends on loading XIOS-PrgEnv/2.0/24708 + +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME $xios_path +%OASIS_HOME $prism_path + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz + +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios + +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIBDIR -L%OASIS_HOME/lib +%OASIS_LIB -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp -Dkey_nosignedzero +%FC ftn + +%FCFLAGS -s real64 -s integer32 -Ovector0 -hfp0 -O0 -hflex_mp=intolerant -e CID +%FFLAGS -s real64 -s integer32 -Ovector0 -hfp0 -O0 -hflex_mp=intolerant -e CID +%LD ftn +%FPPFLAGS -P -E -traditional-cpp +%LDFLAGS -hbyteswapio +%AR ar +%ARFLAGS -r +%MK gmake + +%USER_INC %NCDF_INC %XIOS_INC %OASIS_INC +%USER_LIB %NCDF_LIB %XIOS_LIB %OASIS_LIB %OASIS_LIBDIR + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/arch-linux_gfortran.fcm b/NEMO_4.0.4_surge/arch/arch-linux_gfortran.fcm new file mode 100644 index 0000000..9f767f1 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/arch-linux_gfortran.fcm @@ -0,0 +1,61 @@ +# generic gfortran compiler options for linux +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /usr/local/netcdf +%HDF5_HOME /usr/local/hdf5 +%XIOS_HOME $HOME/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -L/usr/lib/gcc/x86_64-linux-gnu/5 -lstdc++ + +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp -Dkey_nosignedzero +%FC /usr/bin/mpif90 -c -cpp +%FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none +%FFLAGS %FCFLAGS +#%LD /usr/bin/mpif90 -Wl,-rpath=$HOME/INSTALL/lib:/usr/lib +%LD /usr/bin/mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK make +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/arch-linux_ifort.fcm b/NEMO_4.0.4_surge/arch/arch-linux_ifort.fcm new file mode 100644 index 0000000..f83590a --- /dev/null +++ b/NEMO_4.0.4_surge/arch/arch-linux_ifort.fcm @@ -0,0 +1,60 @@ +# generic ifort compiler options for linux +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%XIOS_HOME $xios_path +%OASIS_HOME /not/defiled + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 -lhdf5 +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC ftn -c -cpp +%FCFLAGS -i4 -r8 -O3 -fp-model precise -fno-alias +%FFLAGS %FCFLAGS +%LD ftn +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 + diff --git a/NEMO_4.0.4_surge/arch/arch-linux_ifort_omp.fcm b/NEMO_4.0.4_surge/arch/arch-linux_ifort_omp.fcm new file mode 100644 index 0000000..e695f81 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/arch-linux_ifort_omp.fcm @@ -0,0 +1,32 @@ +# 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC ifort +%FCFLAGS -r8 -O3 -traceback -openmp +%FFLAGS -r8 -O3 -traceback -openmp +%LD ifort +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + +%CC icc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/arch-linux_pgf90.fcm b/NEMO_4.0.4_surge/arch/arch-linux_pgf90.fcm new file mode 100644 index 0000000..24d3cdc --- /dev/null +++ b/NEMO_4.0.4_surge/arch/arch-linux_pgf90.fcm @@ -0,0 +1,30 @@ +# generic pgf90 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC pgf90 +%FCFLAGS -O3 -i4 -r8 +%FFLAGS %FCFLAGS +%LD pgf90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/arch-osx_gfortran.fcm b/NEMO_4.0.4_surge/arch/arch-osx_gfortran.fcm new file mode 100644 index 0000000..708204c --- /dev/null +++ b/NEMO_4.0.4_surge/arch/arch-osx_gfortran.fcm @@ -0,0 +1,68 @@ +# generic gfortran compiler options for OSX installed with macport, http://www.macports.org/ +# +# port packages needed: +# sudo port install openmpi +gcc48 +# sudo port install hdf5-18 +cxx +fortran +openmpi (I'am not sure cxx is needed) +# sudo port install netcdf +openmpi +# sudo port install netcdf-fortran +openmpi +# sudo port install netcdf-cxx +openmpi (I'am not sure it is needed) +# sudo port install p5-uri +# add to your PATH /opt/local/lib/openmpi/bin so that mpif90 is properly known +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /opt/local +%HDF5_HOME /opt/local +%XIOS_HOME /Users/$( whoami )/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp-mp-4.8 -Dkey_nosignedzero +%FC mpif90 +%FCFLAGS -fdefault-real-8 -O3 -funroll-all-loops -fcray-pointer -ffree-line-length-none +%FFLAGS %FCFLAGS +%LD %FC +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK make +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/arch-osx_gfortran_debug.fcm b/NEMO_4.0.4_surge/arch/arch-osx_gfortran_debug.fcm new file mode 100644 index 0000000..bf251ea --- /dev/null +++ b/NEMO_4.0.4_surge/arch/arch-osx_gfortran_debug.fcm @@ -0,0 +1,68 @@ +# generic gfortran compiler options for OSX installed with macport, http://www.macports.org/ +# +# port packages needed: +# sudo port install openmpi +gcc48 +# sudo port install hdf5-18 +cxx +fortran +openmpi (I'am not sure cxx is needed) +# sudo port install netcdf +openmpi +# sudo port install netcdf-fortran +openmpi +# sudo port install netcdf-cxx +openmpi (I'am not sure it is needed) +# sudo port install p5-uri +# add to your PATH /opt/local/lib/openmpi/bin so that mpif90 is properly known +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /opt/local +%HDF5_HOME /opt/local +%XIOS_HOME /Users/$( whoami )/xios-2.5 +%OASIS_HOME /not/defined + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp-mp-4.8 -Dkey_nosignedzero +%FC mpif90 +%FCFLAGS -fdefault-real-8 -O0 -g -fbacktrace -funroll-all-loops -fcray-pointer -ffree-line-length-none -fcheck=bounds -finit-real=nan +%FFLAGS %FCFLAGS +%LD %FC +%LDFLAGS -lstdc++ -lmpi_cxx +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK make +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-ALTIX_JADE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-ALTIX_JADE.fcm new file mode 100644 index 0000000..deba776 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-ALTIX_JADE.fcm @@ -0,0 +1,29 @@ +# ifort compiler options for CINES SGI-ALTIX Jade, http://www.cines.fr/spip.php?rubrique291 +# 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 + + +%NCDF_INC -I/opt/software/SGI/netcdf/4.1.3/include +%NCDF_LIB -L/opt/software/SGI/netcdf/4.1.3/lib -lnetcdf -lnetcdff +%FC ifort -lmpi +%FCFLAGS -r8 -O3 -xSSE4.2 -automatic -static +%FFLAGS %FCFLAGS +%LD %FC +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -ruv +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-BG_BABEL.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-BG_BABEL.fcm new file mode 100644 index 0000000..ad4d22f --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-BG_BABEL.fcm @@ -0,0 +1,29 @@ +# babel IBM BlueGene/P at french IDRIS, http://www.idris.fr/su/Scalaire/babel +# 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 + + +%NCDF_INC -I/bglocal/prod/tools_ibm/netcdf-3.6.1/includ +%NCDF_LIB -L/bglocal/prod/tools_ibm/netcdf-3.6.1/lib -lnetcdf +%FC mpxlf90_r +%FCFLAGS -qfree=f90 -O3 -qrealsize=8 -qextname -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%FFLAGS -qfixed -O3 -qrealsize=8 -qextname -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%LD mpxlf90_r +%LDFLAGS +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-IA64_PLATINE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-IA64_PLATINE.fcm new file mode 100644 index 0000000..71ad8cf --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-IA64_PLATINE.fcm @@ -0,0 +1,29 @@ +# platine BULL cluster at french CCRT, http://www-ccrt.cea.fr/fr/moyen_de_calcul/platine.htm +# 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 + + +%NCDF_INC -I/usr/include +%NCDF_LIB -L usr/lib -lnetcdf -lnetcdff +%FC mpif90 +%FCFLAGS -i4 -r8 -automatic -align all -I/opt/mpi/current/include +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-PW6MONO_VARGAS.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-PW6MONO_VARGAS.fcm new file mode 100644 index 0000000..c9718e1 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-PW6MONO_VARGAS.fcm @@ -0,0 +1,29 @@ +# vargas IBM POWER6 (monoprocessor for tools) at french IDRIS, http://www.idris.fr/su/Scalaire/vargas/hw-vargas.html +# 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 + + +%NCDF_INC -I/usr/local/pub/NetCDF/3.6.2/include +%NCDF_LIB -L /usr/local/pub/NetCDF/3.6.2/lib -lnetcdf +%FC xlf90_r +%FCFLAGS -qfree=f90 -O3 -qstrict -qrealsize=8 -qextname=flush -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%FFLAGS -qfixed -O3 -qstrict -qrealsize=8 -qextname=flush -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%LD xlf90_r +%LDFLAGS +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-PW6_VARGAS.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-PW6_VARGAS.fcm new file mode 100644 index 0000000..1be6a56 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-PW6_VARGAS.fcm @@ -0,0 +1,32 @@ +# vargas IBM POWER6 at french IDRIS, http://www.idris.fr/su/Scalaire/vargas/hw-vargas.html +# 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 +# +# module load netcdf/4.1.3-par +# module load phdf5/1.8.7 +# +%NCDF_INC +%NCDF_LIB +%XIOS_ROOT /workgpfs/rech/eee/reee217/XIOS +%FC mpxlf90_r +%FCFLAGS -qfree=f90 -O3 -qstrict -qrealsize=8 -qextname=flush -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%FFLAGS -qfixed -O3 -qstrict -qrealsize=8 -qextname=flush -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%LD mpCC_r +%LDFLAGS -lxlf90 +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC -I%XIOS_ROOT/inc +%USER_LIB -L%XIOS_ROOT/lib -lxios %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX8_BRODIE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX8_BRODIE.fcm new file mode 100644 index 0000000..1af6300 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX8_BRODIE.fcm @@ -0,0 +1,29 @@ +# brodie NEC SX-8 at french IDRIS, http://www.idris.fr/su/Vectoriel/brodie/hw-brodie.html +# 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 + + +%NCDF_INC -I/SXlocal/pub/netCDF/netCDF-3.6.1/include +%NCDF_LIB -L/SXlocal/pub/netCDF/netCDF-3.6.1/lib -lnetcdf +%FC sxmpif90 +%FCFLAGS -f2003 nocbind -dW -Wf,"-A idbl4",-ptr byte -sx8 -C vopt -Wf"-init stack=nan" -Wl"-f nan" -Wf"-P nh -O overlap" -Wf,-pvctl noassume loopcnt=10000 -Wf"-init heap=zero" -R2 +%FFLAGS %FCFLAGS +%LD sxmpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR sxar +%ARFLAGS rs +%MK sxgmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX8_MERCURE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX8_MERCURE.fcm new file mode 100644 index 0000000..36953ff --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX8_MERCURE.fcm @@ -0,0 +1,30 @@ +# mercure NEC SX-8 at french CCRT, http://www-ccrt.cea.fr/fr/moyen_de_calcul/mercure.htm +# 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 + + +%NCDF_INC -I/ccc/applications/sx8/netcdf-3.6.1/include +%NCDF_LIB -L/ccc/applications/sx8/netcdf-3.6.1/lib -lnetcdf +%FC sxmpif90 +%FCFLAGS -f2003 nocbind -size_t64 -dW -Wf,"-A idbl4", -sx8 -C vopt -P stack -Wf"-init stack=nan" -Wl"-f nan" -Wf"-P nh -O overlap" -Wf"-P nh" -Wf,-pvctl noassume loopcnt=10000 shape=10000000 -Wf"-init heap=zero" -R2 +%FFLAGS %FCFLAGS +%LD sxmpif90 +%LDFLAGS -size_t64 +%FPPFLAGS -P -C -traditional +%AR sxar +%ARFLAGS rs +%MK sxgmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX9_ES2.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX9_ES2.fcm new file mode 100644 index 0000000..3300b08 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX9_ES2.fcm @@ -0,0 +1,30 @@ +# Earth Simulator 2, NEC SX-9, http://www.jamstec.go.jp/esc/index.en.html +# 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 + + +%NCDF_INC -I/SX/usr/include +%NCDF_LIB -L/SX/usr/lib -lnetcdf +%FC sxmpif90 +%FCFLAGS -f2003 nocbind -P stack -dW -Wf,-pvctl res=whole,-A idbl4,-ptr byte -EP -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -Wf"-init heap=zero" -R2 +%FFLAGS %FCFLAGS +%LD sxmpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR sxar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX9_MERCURE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX9_MERCURE.fcm new file mode 100644 index 0000000..a47f088 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-SX9_MERCURE.fcm @@ -0,0 +1,30 @@ +# mercure NEC SX-9 at french CCRT, http://www-ccrt.cea.fr/fr/moyen_de_calcul/mercure.htm +# 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 + + +%NCDF_INC -I/usr/local/SX8/soft/netcdf/include +%NCDF_LIB -L/usr/local/SX8/soft/netcdf/lib -lnetcdf +%FC sxmpif90 +%FCFLAGS -f2003 nocbind -P stack -dW -Wf,-pvctl res=whole,-A idbl4,-ptr byte -EP -R5 -float0 -size_t64 -dw -Wf,"-pvctl loopcnt=999999 fullmsg noassume" -Wf"-init heap=zero" -R2 +%FFLAGS %FCFLAGS +%LD sxmpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR sxar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-TX7_ULAM.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-TX7_ULAM.fcm new file mode 100644 index 0000000..36138cd --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-TX7_ULAM.fcm @@ -0,0 +1,29 @@ +# ulam IBM X3950 M2 at french IDRIS, http://www.idris.fr/su/Scalaire/ulam/hw-ulam.html +# 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 + + +%NCDF_INC -I/usr/local/pub/NetCDF/3.6.3/include +%NCDF_LIB -L/usr/local/pub/NetCDF/3.6.3/lib -lnetcdf_c++ -lnetcdf +%FC ifort +%FCFLAGS -r8 -O3 -traceback +%FFLAGS %FCFLAGS +%LD %FC +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X64_CURIE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X64_CURIE.fcm new file mode 100644 index 0000000..8689911 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X64_CURIE.fcm @@ -0,0 +1,59 @@ +# Curie BULL at TGCC, http://www-hpc.cea.fr/en/complexe/tgcc-curie.htm +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /usr/local/netcdf-4.3.3.1_hdf5_parallel +%HDF5_HOME /usr/local/hdf5-1.8.12_parallel +%XIOS_HOME $WORKDIR/xios-2.5 +%OASIS_HOME $WORKDIR/now/models/oa3mct + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 -lhdf5 +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios -lstdc++ +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 -O3 -fp-model precise -xAVX -fno-alias +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X64_TITANE.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X64_TITANE.fcm new file mode 100644 index 0000000..31ff8ae --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X64_TITANE.fcm @@ -0,0 +1,28 @@ +# titane BULL at french CCRT, http://www-ccrt.cea.fr/fr/moyen_de_calcul/titane.htm +# 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 + +%NCDF_INC -I$NETCDF_INC_DIR +%NCDF_LIB -L$NETCDF_LIB_DIR -lnetcdff -lnetcdf +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 -DCPP_PARA -O3 -automatic -align all +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X86_CESIUM.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X86_CESIUM.fcm new file mode 100644 index 0000000..146e23a --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-X86_CESIUM.fcm @@ -0,0 +1,29 @@ +# cesium pre/post processing HP at french CCRT, http://www-ccrt.cea.fr/fr/moyen_de_calcul/cesium.htm +# 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 + + +%NCDF_INC -I/applications/netcdf-3.6.3/include +%NCDF_LIB -L/applications/netcdf-3.6.3/lib -lnetcdff -lnetcdf +%FC ifort +%FCFLAGS -i4 -r8 +%FFLAGS %FCFLAGS +%LD ifort +%LDFLAGS -Vaxlib +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/CNRS/arch-ifort_CICLAD.fcm b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-ifort_CICLAD.fcm new file mode 100644 index 0000000..3243cac --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/CNRS/arch-ifort_CICLAD.fcm @@ -0,0 +1,29 @@ +# 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 + + +%NCDF_INC -I/opt/netcdf3/ifort/include +%NCDF_LIB -L /opt/netcdf3/ifort/lib -lnetcdf +%FC /usr/lib64/openmpi/1.4.3-ifort/bin/mpif90 -c -cpp -DCPP_PARA -pg +%FCFLAGS -i4 -r8 -O3 -traceback +%FFLAGS -i4 -r8 -O3 -traceback +%LD /usr/lib64/openmpi/1.4.3-ifort/bin/mpif90 +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/MERCATOR/arch-ifort_MERCATOR_CLUSTER.fcm b/NEMO_4.0.4_surge/arch/depr/MERCATOR/arch-ifort_MERCATOR_CLUSTER.fcm new file mode 100644 index 0000000..3bc0b5d --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/MERCATOR/arch-ifort_MERCATOR_CLUSTER.fcm @@ -0,0 +1,32 @@ +# 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 +# debug: -g -check bounds -check uninit -check pointers -traceback + +%NCDF_INC -I$NETCDF_INC +%NCDF_LIB -L$NETCDF_LIB -lnetcdff -lnetcdf -L$HDF5_LIB -lhdf5_hl -lhdf5 -lz + +%CPP cpp +%FC mpif90 +%FCFLAGS -O2 -fp-model precise -traceback -r8 -convert big_endian -assume byterecl +%FFLAGS %FCFLAGS +%LD mpif90 +%FPPFLAGS -P -C -traditional +%LDFLAGS -O2 +%AR ar +%ARFLAGS -rs +%MK gmake +%USER_INC -I$XIOS_INC %NCDF_INC +%USER_LIB -L$XIOS_LIB -lxios %NCDF_LIB -lstdc++ + diff --git a/NEMO_4.0.4_surge/arch/depr/NOC/arch-ALTIX_NAUTILUS.fcm b/NEMO_4.0.4_surge/arch/depr/NOC/arch-ALTIX_NAUTILUS.fcm new file mode 100644 index 0000000..1f1a6e9 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/NOC/arch-ALTIX_NAUTILUS.fcm @@ -0,0 +1,33 @@ +# ifort (mpif90) compiler options for NOCS ALTIX cluster nautilus +# 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 + + +%NCDF_INC -I/sw/packages/netcdf/3.6.2/x86_64/include +%NCDF_LIB -L/sw/packages/netcdf/3.6.2/x86_64/lib -lnetcdf +%FC mpif90 +%FCFLAGS -r8 -O3 -xT -ip -vec-report0 +%FFLAGS -r8 -O3 -xT -ip -vec-report0 +%LD mpif90 +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + +# - if debugging use these flags +#FCFLAGS -g -traceback -r8 -O0 -xT -ip -vec-report0 +#FFLAGS -g -traceback -r8 -O0 -xT -ip -vec-report0 diff --git a/NEMO_4.0.4_surge/arch/depr/NOC/arch-XT6_HECTORcrayftn.fcm b/NEMO_4.0.4_surge/arch/depr/NOC/arch-XT6_HECTORcrayftn.fcm new file mode 100644 index 0000000..8d2f109 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/NOC/arch-XT6_HECTORcrayftn.fcm @@ -0,0 +1,44 @@ +# compiler options for hector CRAY XT6 (using crayftn compiler) + +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# 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 + + +# PrgEnv-cray (default for hector phase 3) +# use "module load netcdf/4.1.2" to setup netcdf (defines NETCDF_DIR and HDF5_DIR) + +%NCDF_HOME $NETCDF_DIR +%HDF5_HOME $HDF5_DIR +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdf -lhdf5_fortran -lhdf5_hl -lhdf5 -lz +%FC ftn +%FCFLAGS -em -s integer32 -s real64 -O3 +%FFLAGS -em -s integer32 -s real64 -O3 +%LD ftn +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + +# replacement options for GNU prgenv + +# %NCDF_HOME $CRAY_NETCDF_DIR/netcdf-gnu +# %HDF5_HOME $CRAY_HDF5_DIR/hdf5-gnu +# %FCFLAGS -fdefault-real-8 -O3 +# %FFLAGS -fdefault-real-8 -O3 diff --git a/NEMO_4.0.4_surge/arch/depr/NOC/arch-pgf90_mobius.fcm b/NEMO_4.0.4_surge/arch/depr/NOC/arch-pgf90_mobius.fcm new file mode 100644 index 0000000..82dcbc9 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/NOC/arch-pgf90_mobius.fcm @@ -0,0 +1,32 @@ +# mpi compiler options for NOCL's cluster Mobius +# 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 + + +%NCDF_INC -I/cm/shared/apps/netcdf/pgi/64/4.1.1/include -I/usr/mpi/qlogic/include +%NCDF_LIB -L/cm/shared/apps/pgi/7.1-6/linux86-64/7.1-6/lib -L/usr/mpi/qlogic/lib64 -L/cm/shared/apps/netcdf/pgi/64/4.1.1/lib -lnetcdf +%FC mpif90 -c +%FCFLAGS -i4 -r8 -O3 -Mfree +## FCFLAGS for debugging +#%FCFLAGS -i4 -r8 -Mfree -Ktrp=fp -g -C +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/UKMO/arch-PW6_METO.fcm b/NEMO_4.0.4_surge/arch/depr/UKMO/arch-PW6_METO.fcm new file mode 100644 index 0000000..3a651f9 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/UKMO/arch-PW6_METO.fcm @@ -0,0 +1,29 @@ +# IBM POWER6 UKMO +# 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 + + +%NCDF_INC -I/opt/netcdf/netcdf-3.6.0-p1_ec/include +%NCDF_LIB -L /opt/netcdf/netcdf-3.6.0-p1_ec/lib -lnetcdf +%FC mpxlf90_r +%FCFLAGS -qrealsize=8 -qextname -qsuffix=f=f90 -qarch=pwr6 -NS32768 -I/opt/netcdf-3.6.0-p1_ex/include -qxflag=p6div:p6divmsg -g -O3 -qnostrict +%FFLAGS -qrealsize=8 -qextname -qsuffix=f=f90 -qarch=pwr6 -NS32768 -I/opt/netcdf-3.6.0-p1_ex/include -qxflag=p6div:p6divmsg -g -O3 -qnostrict +%LD mpxlf90_r +%LDFLAGS -L /opt/netcdf/netcdf-3.6.0-p1_ec/lib -lnetcdf -O3 -L/projects/um1/lib -lsig -O3 -L MASS +%FPPFLAGS -E -P -traditional -I/usr/lpp/ppe.poe/include/thread64 +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/UKMO/arch-XT6_HECTOR.fcm b/NEMO_4.0.4_surge/arch/depr/UKMO/arch-XT6_HECTOR.fcm new file mode 100644 index 0000000..da03555 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/UKMO/arch-XT6_HECTOR.fcm @@ -0,0 +1,44 @@ +# compiler options for hector CRAY XT6 + +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# 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 + + +# PGI prgenv (default for hector) +# use "module load netcdf" to setup system netcdf + +%NCDF_HOME $CRAY_NETCDF_DIR/netcdf-pgi +%HDF5_HOME $CRAY_HDF5_DIR/hdf5-pgi +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdf -lhdf5_fortran -lhdf5_hl -lhdf5 -lz +%FC ftn +%FCFLAGS -i4 -r8 -O3 +%FFLAGS -i4 -r8 -O3 +%LD ftn +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + +# replacement options for GNU prgenv + +# %NCDF_HOME $CRAY_NETCDF_DIR/netcdf-gnu +# %HDF5_HOME $CRAY_HDF5_DIR/hdf5-gnu +# %FCFLAGS -fdefault-real-8 -O3 +# %FFLAGS -fdefault-real-8 -O3 diff --git a/NEMO_4.0.4_surge/arch/depr/arch-linux_g95.fcm b/NEMO_4.0.4_surge/arch/depr/arch-linux_g95.fcm new file mode 100644 index 0000000..c8bdd0b --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-linux_g95.fcm @@ -0,0 +1,30 @@ +# generic g95 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC g95 +%FCFLAGS -i4 -r8 -O3 -funroll-all-loops -fno-second-underscore +%FFLAGS %FCFLAGS +%LD g95 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/arch-linux_lahey.fcm b/NEMO_4.0.4_surge/arch/depr/arch-linux_lahey.fcm new file mode 100644 index 0000000..0e64981 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-linux_lahey.fcm @@ -0,0 +1,30 @@ +# generic Lahey/Fujitsu 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC lf95 +%FCFLAGS -i4 -CcdRR8 +%FFLAGS %FCFLAGS +%LD lf95 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/arch-linux_nag.fcm b/NEMO_4.0.4_surge/arch/depr/arch-linux_nag.fcm new file mode 100644 index 0000000..401f42f --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-linux_nag.fcm @@ -0,0 +1,30 @@ +# generic NagWare 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC f95 +%FCFLAGS -i4 -r8 -gline -O3 +%FFLAGS %FCFLAGS +%LD f95 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/arch-linux_pathscale.fcm b/NEMO_4.0.4_surge/arch/depr/arch-linux_pathscale.fcm new file mode 100644 index 0000000..e933825 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-linux_pathscale.fcm @@ -0,0 +1,30 @@ +# generic pathscale 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC pathf95 +%FCFLAGS -r8 -O3 -funroll +%FFLAGS %FCFLAGS +%LD pathf95 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/arch-mpxlf_aix.fcm b/NEMO_4.0.4_surge/arch/depr/arch-mpxlf_aix.fcm new file mode 100644 index 0000000..3dc72ec --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-mpxlf_aix.fcm @@ -0,0 +1,29 @@ +# generic IBM SP +# 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 + + +%NCDF_INC -I/usr/local/pub/NetCDF/3.6.2/include +%NCDF_LIB -L /usr/local/pub/NetCDF/3.6.2/lib -lnetcdf +%FC mpxlf90_r +%FCFLAGS -qfree=f90 -O3 -qrealsize=8 -qextname -qsource -q64 -qlargepage -qmaxmem=-1 +%FFLAGS -qfixed -O3 -qrealsize=8 -qextname -qsource -q64 -qlargepage -qmaxmem=-1 +%LD mpxlf90_r +%LDFLAGS +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/arch-osx_g95.fcm b/NEMO_4.0.4_surge/arch/depr/arch-osx_g95.fcm new file mode 100644 index 0000000..ac6e7aa --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-osx_g95.fcm @@ -0,0 +1,30 @@ +# generic g95 compiler options for OSX (intel) +# 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 + + +%NCDF_INC -I/usr/local/netcdf/include +%NCDF_LIB -L/usr/local/netcdf/lib -lnetcdf +%FC g95 +%FCFLAGS -i4 -r8 -O3 -funroll-all-loops +%FFLAGS %FCFLAGS +%LD g95 +%LDFLAGS +%FPPFLAGS -P -C -traditional +%AR libtool +%ARFLAGS -c -s -o +%MK make +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB + diff --git a/NEMO_4.0.4_surge/arch/depr/arch-osx_ifort.fcm b/NEMO_4.0.4_surge/arch/depr/arch-osx_ifort.fcm new file mode 100644 index 0000000..bb1e632 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-osx_ifort.fcm @@ -0,0 +1,29 @@ +# generic ifort (with mpi) compiler options for OSX (intel) +# 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 + + +%NCDF_INC -I/usr/local/include +%NCDF_LIB -L /usr/local/lib -lnetcdf +%FC mpif90 +%FCFLAGS -r8 -O3 -traceback +%FFLAGS -r8 -O3 -traceback +%LD mpif90 +%FPPFLAGS -P -C -traditional +%LDFLAGS +%AR libtool +%ARFLAGS -c -s -o +%MK make +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/arch-osx_xlf.fcm b/NEMO_4.0.4_surge/arch/depr/arch-osx_xlf.fcm new file mode 100644 index 0000000..534f61a --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/arch-osx_xlf.fcm @@ -0,0 +1,29 @@ +# generic xlf compiler options for OSX (ppc) +# 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 + + +%NCDF_INC -I/usr/local/XLF/netcdf/include +%NCDF_LIB -L/usr/local/XLF/netcdf/lib -lnetcf +%FC xlf90 +%FCFLAGS -O3 -qrealsize=8 -qextname -qsuffix=f=f90 -qsuffix=cpp=F90 +%FFLAGS -O3 -qrealsize=8 -qextname -qsuffix=f=f -qsuffix=cpp=F +%FPPFLAGS -P -C -traditional +%LD xlf90 +%LDFLAGS +%AR ar +%ARFLAGS rs +%MK make +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/misc/arch-PW6_C1A.fcm b/NEMO_4.0.4_surge/arch/depr/misc/arch-PW6_C1A.fcm new file mode 100644 index 0000000..aa82328 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/misc/arch-PW6_C1A.fcm @@ -0,0 +1,29 @@ +# POWER 6 at ECMWF +# 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 +#-g -C -qsigtrap + +%NCDF_INC -I /usr/local/apps/netcdf/3.6.3/LP64/include +%NCDF_LIB -L /usr/local/apps/netcdf/3.6.3/LP64/lib -lnetcdf +%FC mpxlf90_r +%FCFLAGS -qfree=f90 -O3 -qrealsize=8 -qextname -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%FFLAGS -qfixed -O3 -qrealsize=8 -qextname -qsource -q64 -qlargepage -qmaxmem=-1 -qsource +%LD mpxlf90_r +%LDFLAGS +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/misc/arch-X64_VAYU.fcm b/NEMO_4.0.4_surge/arch/depr/misc/arch-X64_VAYU.fcm new file mode 100644 index 0000000..ce8993b --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/misc/arch-X64_VAYU.fcm @@ -0,0 +1,59 @@ +# Vayu Sun Constellation at Australian NCI, http://nf.nci.org.au/facilities/vayu/hardware.php +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /short/e14/$( whoami )/util +%HDF5_HOME /short/e14/$( whoami )/util +%XIOS_HOME /short/e14/$( whoami )/now/models/xios +%OASIS_HOME /short/e14/$( whoami )/now/models/oa3mct + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 -lhdf5 -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/depr/misc/arch-X64_YELLOWSTONE.fcm b/NEMO_4.0.4_surge/arch/depr/misc/arch-X64_YELLOWSTONE.fcm new file mode 100644 index 0000000..6df53cf --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/misc/arch-X64_YELLOWSTONE.fcm @@ -0,0 +1,59 @@ +# Yellowstone IBM at NCAR, http://www2.cisl.ucar.edu/resources/yellowstone +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# 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 +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +%NCDF_HOME /glade/apps/opt/netcdf-mpi/4.2/intel/12.1.4 +%HDF5_HOME /glade/apps/opt/hdf5-mpi/1.8.9/intel/12.1.4 +%XIOS_HOME /glade/p/work/$( whoami )/now/models/xios +%OASIS_HOME /glade/p/work/$( whoami )/now/models/oa3mct + +%NCDF_INC -I%NCDF_HOME/include +%NCDF_LIB -L%NCDF_HOME/lib -lnetcdff -lnetcdf -L%HDF5_HOME/lib -lhdf5_hl -lhdf5 -lhdf5 +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +%OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +%OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp +%FC mpif90 -c -cpp +%FCFLAGS -i4 -r8 -O3 -fp-model precise -xAVX +%FFLAGS %FCFLAGS +%LD mpif90 +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc +%CFLAGS -O0 diff --git a/NEMO_4.0.4_surge/arch/depr/misc/arch-xlf_aix.fcm b/NEMO_4.0.4_surge/arch/depr/misc/arch-xlf_aix.fcm new file mode 100644 index 0000000..310a3f2 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/misc/arch-xlf_aix.fcm @@ -0,0 +1,29 @@ +# generic IBM SP +# 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 + + +%NCDF_INC -I/usr/local/pub/NetCDF/3.6.2/include +%NCDF_LIB -L /usr/local/pub/NetCDF/3.6.2/lib -lnetcdf +%FC xlf90_r +%FCFLAGS -qsuffix=f=f90 -qrealsize=8 -qextname -NS32768 -qnostrict -O5 -d -qsmp=omp -qhot -qessl -qipa -qreport +%FFLAGS -qrealsize=8 -qextname -NS32768 -qnostrict -O5 -d -qsmp=omp -qhot -qessl -qipa -qreport +%LD xlf90_r +%LDFLAGS +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/depr/misc/arch-xlf_pwr6.fcm b/NEMO_4.0.4_surge/arch/depr/misc/arch-xlf_pwr6.fcm new file mode 100644 index 0000000..f86e817 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/depr/misc/arch-xlf_pwr6.fcm @@ -0,0 +1,29 @@ +# generic IBM SP +# 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 + + +%NCDF_INC -I/usr/local/pub/NetCDF/3.6.2/include +%NCDF_LIB -L /usr/local/pub/NetCDF/3.6.2/lib -lnetcdf +%FC xlf90_r +%FCFLAGS -qsuffix=f=f90 -qrealsize=8 -qextname -qarch=pwr6 -qtune=pwr6 -NS32768 -qxflag=p6div:p6divmsg -qnostrict -O5 -d -qsmp=omp -qhot -qessl -qipa -qreport +%FFLAGS -qrealsize=8 -qextname -qarch=pwr6 -qtune=pwr6 -NS32768 -qxflag=p6div:p6divmsg -qnostrict -O5 -d -qsmp=omp -qhot -qessl -qipa -qreport +%LD xlf90_r +%LDFLAGS +%FPPFLAGS -P -C +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC %NCDF_INC +%USER_LIB %NCDF_LIB diff --git a/NEMO_4.0.4_surge/arch/misc/arch-PW7_C2A_XIO.fcm b/NEMO_4.0.4_surge/arch/misc/arch-PW7_C2A_XIO.fcm new file mode 100644 index 0000000..9e8b618 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/misc/arch-PW7_C2A_XIO.fcm @@ -0,0 +1,54 @@ +# POWER 6 at ECMWF +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_iomput is activated) +# XIOS_LIB xios library (taken into accound only if key_iomput is activated) +# +# 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 complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables "$..." are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +#options: +# +#debug : g -C -qinitauto=7FBFFFFF -qfloat=nans -qflttrap=overflow:underflow:zerodivide:invalid:enable +#portage : -qsource +#format : -qfree=f90 -qfixed -qsuffix=f=f90 -qsuffix=cpp=F90 +#others : -qmaxmem=-1 -qsave -qlargepage +# +%NCDF_INC -I${NETCDF_INC1} +%NCDF_LIB -L${NETCDF_LIB1} -lnetcdff -lnetcdf -L${HDF5_LIB} -lhdf5_hl -lhdf5 -lz +%XIOS_INC -I${XIOS_INC} +%XIOS_LIB -L${XIOS_LIB} -lxios + +%XLF90_LIB -lxlf90_r + +%CPP cpp +%FC mpxlf90_r +%FCFLAGS -qsuffix=f=f90 -qsuffix=cpp=F90 -qfree=f90 -O3 -qrealsize=8 -qarch=auto -qtune=auto -qinitauto +%FFLAGS -qsuffix=f=f90 -qsuffix=cpp=F90 -qfixed -O3 -qrealsize=8 -qarch=auto -qtune=auto -qinitauto +%LD mpCC_r +%FPPFLAGS +%LDFLAGS -O2 +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB %XLF90_LIB + +%CC xlc +%CFLAGS -O -qcpluscmt diff --git a/NEMO_4.0.4_surge/arch/misc/arch-X64_BULL.fcm b/NEMO_4.0.4_surge/arch/misc/arch-X64_BULL.fcm new file mode 100644 index 0000000..1f5db75 --- /dev/null +++ b/NEMO_4.0.4_surge/arch/misc/arch-X64_BULL.fcm @@ -0,0 +1,31 @@ +# 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 +%FC mpiifort -c -cpp +%FCFLAGS -g -i4 -r8 -O3 -fp-model precise -march=native -mtune=native -qoverride-limits -fno-alias -qopt-report=4 -align array64byte -traceback +%FFLAGS %FCFLAGS +%LD scorep-mpiifort +%LDFLAGS -lstdc++ +%FPPFLAGS -P -C -traditional -std=c99 +%AR ar +%ARFLAGS rs +%MK gmake +%USER_INC -I/empty +%USER_LIB -lnetcdff -lnetcdf -lhdf5 + +%CC mpiicc +%CFLAGS -O3 -march=native -mtune=native diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/context_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/context_nemo.xml new file mode 100644 index 0000000..a12b8bd --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/context_nemo.xml @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/domain_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/domain_def_nemo.xml new file mode 100644 index 0000000..0931e2b --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/domain_def_nemo.xml @@ -0,0 +1,198 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/field_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/field_def_nemo-oce.xml new file mode 100644 index 0000000..62b0bb6 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/field_def_nemo-oce.xml @@ -0,0 +1,1129 @@ + + + + + + + + + + + + + + + + + + + + + + + toce_pot * e3t + + soce_pra * e3t + + + toce_con * e3t + + soce_abs * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + sst_pot * sst_pot + + + + + + + + + + + + sss_pra * sss_pra + + + + + + + sst_con * sst_con + + + + + + + + + + + + sss_abs * sss_abs + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + uoce * uoce * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + voce * voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + ut * e3u + + us * e3u + + urhop * e3u + + vt * e3v + + vs * e3v + + vrhop * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + @voce_e3v + + this * e1v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sophtvtr - sophtove + sophtvtr - sopstove + + + + + + + + + + + + + + + + + + + ttrd_atf * e3t + strd_atf * e3t + + ttrd_atf_e3t * 1026.0 * 3991.86795711963 + strd_atf_e3t * 1026.0 * 0.001 + + + + + + + + + + + sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) + sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) + + + + + + + + + + + + + ttrd_ldf + ttrd_zdf - ttrd_zdfp + strd_ldf + strd_zdf - strd_zdfp + + + + + + + + + + + + + + + + + ttrd_xad * e3t + strd_xad * e3t + ttrd_yad * e3t + strd_yad * e3t + ttrd_zad * e3t + strd_zad * e3t + ttrd_ad * e3t + strd_ad * e3t + ttrd_totad * e3t + strd_totad * e3t + ttrd_ldf * e3t + strd_ldf * e3t + ttrd_zdf * e3t + strd_zdf * e3t + ttrd_evd * e3t + strd_evd * e3t + + + ttrd_iso * e3t + strd_iso * e3t + ttrd_zdfp * e3t + strd_zdfp * e3t + + + ttrd_dmp * e3t + strd_dmp * e3t + ttrd_bbl * e3t + strd_bbl * e3t + ttrd_npc * e3t + strd_npc * e3t + ttrd_qns * e3ts + strd_cdt * e3ts + ttrd_qsr * e3t + ttrd_bbc * e3t + + + ttrd_totad_e3t * 1026.0 * 3991.86795711963 + strd_totad_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + ttrd_iso_e3t * 1026.0 * 3991.86795711963 + strd_iso_e3t * 1026.0 * 0.001 + ttrd_zdfp_e3t * 1026.0 * 3991.86795711963 + strd_zdfp_e3t * 1026.0 * 0.001 + ttrd_qns_e3t * 1026.0 * 3991.86795711963 + ttrd_qsr_e3t * 1026.0 * 3991.86795711963 + ttrd_bbl_e3t * 1026.0 * 3991.86795711963 + strd_bbl_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + + + + + + + + + ttrd_tot * e3t + strd_tot * e3t + + ttrd_tot_e3t * 1026.0 * 3991.86795711963 + strd_tot_e3t * 1026.0 * 0.001 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/field_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/field_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/file_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/file_def_nemo-oce.xml new file mode 100644 index 0000000..c752ddb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/file_def_nemo-oce.xml @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/file_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/file_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/grid_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/grid_def_nemo.xml new file mode 100644 index 0000000..b370feb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/grid_def_nemo.xml @@ -0,0 +1,180 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/EXP_tideonly/iodef.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/iodef.xml similarity index 90% rename from EXP_tideonly/iodef.xml rename to NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/iodef.xml index 9a1f846..8bfff14 100644 --- a/EXP_tideonly/iodef.xml +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/iodef.xml @@ -5,17 +5,16 @@ - + - 0 + -1 true false oceanx - @@ -23,5 +22,5 @@ - + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/namelist_cfg b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/namelist_cfg new file mode 100644 index 0000000..a16581c --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/namelist_cfg @@ -0,0 +1,351 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! AMM12 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = "AMMSURGE" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 52560 ! last time step (std 1 day = 144) + nn_date0 = 20130101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_leapy = 1 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + cn_ocerst_in = "ammsurge_restart_oce" ! suffix of ocean restart name (input) + cn_ocerst_out = "restart_oce_out" ! suffix of ocean restart name (input) + nn_stock = 52560 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 52560 ! frequency of write in the output file (modulo referenced to nit000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 450. ! time step for the dynamics (and tracer if nn_acc=0) + ln_2d = .true. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: user defined GYRE) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + cn_domcfg = "amm7_surge_domain_cfg" ! domain configuration filename +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells +/ +!!====================================================================== +!! *** 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 (surface module) (default: NO selection) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of SBC module call + ln_usr = .true. + ln_flx = .false. ! flux formulation (T => fill namsbc_flx) + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .true. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) +/ +!----------------------------------------------------------------------- +&namsbc_usr ! namsbc_surge surge model fluxes +!----------------------------------------------------------------------- + ln_use_sbc = .true. ! (T) to turn on surge fluxes (wind and pressure only) + ! (F) for no fluxes (ie tide only case) + +! +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! + sn_wndi = 'windspd_u_amm7' , 1 ,'x_wind', .true. , .false. , 'daily' ,'' , '' + sn_wndj = 'windspd_v_amm7' , 1 ,'y_wind', .true. , .false. , 'daily' ,'' , '' + cn_dir = './fluxes/' ! root directory for the location of the bulk files + rn_vfac = 1. ! multiplicative factor for ocean/ice velocity + ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) + rn_charn_const = 0.0275 +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101200. ! reference atmospheric pressure [N/m2] + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .true. ! inverse barometer added to OBC ssh data + + cn_dir = './fluxes/' ! root directory for the Patm 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_apr = 'pressure_amm7', 1 , 'air_pressure_at_sea_level' , .true. , .false., 'daily' , '' , '' , '' +/ +!!====================================================================== +!! *** 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 = 0 ! free slip +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .true. + clname(1) = 'Q1' ! name of constituent + clname(2) = 'O1' + clname(3) = 'P1' + clname(4) = 'K1' + clname(5) = '2N2' + clname(6) = 'MU2' + clname(7) = 'N2' + clname(8) = 'NU2' + clname(9) = 'M2' + clname(10) = 'L2' + clname(11) = 'T2' + clname(12) = 'S2' + clname(13) = 'K2' + clname(14) = 'M4' + clname(15) = '2MK6' + clname(16) = '2MS6' + clname(17) = '2SM2' + clname(18) = '3M2S2' + clname(19) = 'Lam2' + clname(20) = 'M6' + clname(21) = 'MK3' + clname(22) = 'MN4' + clname(23) = 'MNS2' + clname(24) = 'MO3' + clname(25) = 'MS4' + clname(26) = 'MSN2' +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .true. + nb_bdy = 1 ! number of open boundary sets + cn_dyn2d = 'flather' ! + nn_dyn2d_dta = 2 ! = 0, bdy data are equal to the initial state + ! = 1, bdy data are read in 'bdydata .nc' files + ! = 2, use tidal harmonic forcing data from files + ! = 3, use external data AND tidal harmonic forcing +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries +!----------------------------------------------------------------------- + filtide = 'bdydta/amm7_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .true. +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!! !! +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T) +!! namdrg_bot bottom friction (ln_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_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction +!----------------------------------------------------------------------- + rn_Cd0 = 2.4e-3 ! drag coefficient [-] + rn_ke0 = 0.0e0 ! background kinetic energy [m2/s2] (non-linear cases) +/ +!!====================================================================== +!! 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_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) +/ +!----------------------------------------------------------------------- +&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 scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .true. ! Number of sub-step defined from: +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_blp = .true. ! bilaplacian operator + ln_dynldf_lap = .false. ! bilaplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = 0 ! =0 constant = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.012 ! lateral viscous velocity [m/s] + rn_Lv = 1.e+4 ! lateral viscous length [m] +/ +!!====================================================================== +!! 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 (default: NO selection) +!----------------------------------------------------------------------- + rn_avm0 = 0.1e-6 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.1e-6 ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_charn = 100000. ! Charnock constant for wb induced roughness length + nn_z0_met = 1 ! Method for surface roughness computation (0/1/2) +/ +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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 ("key_float") +!! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") +!! namdct transports through some sections ("key_diadct") +!! nam_diatmb Top Middle Bottom Output (default: OFF) +!! nam_dia25h 25h Mean Output (default: OFF) +!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_diatmb ! Top Middle Bottom Output (default F) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default F) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .false. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/namelist_ref b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/namelist_ref new file mode 100644 index 0000000..f0d5a35 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP00/namelist_ref @@ -0,0 +1,1383 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : Reference namelist_ref !! +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : 1 - Domain & run manager (namrun, namcfg, namdom, namtsd, namcrs, namc1d, namc1d_uvd) +!! namelists 2 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_cpl, +!! namsbc_sas, namtra_qsr, namsbc_rnf, +!! namsbc_isf, namsbc_iscpl, namsbc_apr, +!! namsbc_ssr, namsbc_wave, namberg) +!! 3 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide) +!! 4 - top/bot boundary (namdrg, namdrg_top, namdrg_bot, nambbc, nambbl) +!! 5 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_eiv, namtra_dmp) +!! 6 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) +!! 7 - Vertical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_gls, namzdf_iwm) +!! 8 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb) +!! 9 - Obs & Assim (namobs, nam_asminc) +!! 10 - miscellaneous (nammpp, namctl, namsto) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!!====================================================================== +!! *** 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! Assimilation cycle index + cn_exp = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5840) + nn_date0 = 010101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_time0 = 0 ! initial time of day in hhmm + nn_leapy = 0 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T + nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T + ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist + ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart + ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "." ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "." ! directory in which to write output ocean restarts + ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model + nn_istate = 0 ! output the initial state (1) or not (0) + ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) + nn_stock = 0 ! used only if ln_rst_list = F: output restart freqeuncy (modulo referenced to 1) + ! ! = 0 force to write restart files only at the end of the run + ! ! = -1 do not do any restart + nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written + nn_write = 0 ! used only if key_iomput is not defined: output frequency (modulo referenced to nn_it000) + ! ! = 0 force to write output files only at the end of the run + ! ! = -1 do not do any output file + ln_mskland = .false. ! mask land points in NetCDF outputs + ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + ln_xios_read = .FALSE. ! use XIOS to read restart file (only for a single file restart) + nn_wxios = 0 ! use XIOS to write restart file 0 - no, 1 - single file output, 2 - multiple file output + ln_rst_eos = .TRUE. ! check if the equation of state used to produce the restart is consistent with model +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.00 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 5400. ! time step for the dynamics and tracer + rn_atfp = 0.1 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_2d = .false. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration (F => create/check namusr_def) + cn_domcfg = "domain_cfg" ! domain configuration filename + ! + ln_closea = .false. ! T => keep closed seas (defined by closea_mask field) in the + ! ! domain and apply special treatment of freshwater fluxes. + ! ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. + ! ! If closea_mask field doesn't exist in the domain_cfg file + ! ! then this logical does nothing. + ln_write_cfg = .false. ! (=T) create the domain configuration file + cn_domcfg_out = "domain_cfg_out" ! newly created domain configuration filename + ! + ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present + ! ! in netcdf input files, as the start j-row for reading +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .false. ! ocean initialisation + ln_tsd_dmp = .false. ! 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' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_il = .false. ! T/F activation of iterative limiter + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells + rn_wdld = 2.5 ! Land elevation below which WaD is allowed + nn_wdit = 20 ! Max iterations for WaD limiter + rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes + rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) +/ +!----------------------------------------------------------------------- +&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T) +!----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_binref = 0 ! Bin centering preference: NORTH or EQUAT + ! ! 0, coarse grid is binned with preferential treatment of the north fold + ! ! 1, coarse grid is binned with centering at the equator + ! ! Symmetry with nn_facty being odd-numbered. Asymmetry with even-numbered nn_facty. + ln_msh_crs = .false. ! =T create a mesh & mask file + nn_crs_kz = 0 ! 0, MEAN of volume boxes + ! ! 1, MAX of boxes + ! ! 2, MIN of boxes + ln_crs_wn = .true. ! wn coarsened (T) or computed using horizontal divergence ( F ) +/ +!----------------------------------------------------------------------- +&namc1d ! 1D configuration options ("key_c1d" default: PAPA station) +!----------------------------------------------------------------------- + rn_lat1d = 50 ! Column latitude + rn_lon1d = -145 ! Column longitude + ln_c1d_locpt = .true. ! Localization of 1D config in a grid (T) or independant point (F) +/ +!----------------------------------------------------------------------- +&namc1d_dyndmp ! U & V newtonian damping ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ln_dyndmp = .false. ! add a damping term (T) or not (F) +/ +!----------------------------------------------------------------------- +&namc1d_uvd ! data: U & V currents ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ! ! =T read U-V fields for: + ln_uvd_init = .false. ! ocean initialisation + ln_uvd_dyndmp = .false. ! U-V restoring + + cn_dir = './' ! root directory for the U-V 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_ucur = 'ucurrent' , -1. ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' + sn_vcur = 'vcurrent' , -1. ,'v_current', .false. , .true. , 'monthly' , '' , 'Vme' , '' +/ + +!!====================================================================== +!! *** 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 = 2 ! frequency of SBC module call + ! ! (control sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_usr = .false. ! user defined formulation (T => check usrdef_sbc) + ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + ! ! Type of coupling (Ocean/Ice/Atmosphere) : + ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) + ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) + nn_components = 0 ! configuration of the opa-sas OASIS coupling + ! ! =0 no opa-sas OASIS coupling: default single executable config. + ! ! =1 opa-sas OASIS coupling: multi executable config., OPA component + ! ! =2 opa-sas OASIS coupling: multi executable config., SAS component + ! Sea-ice : + nn_ice = 0 ! =0 no ice boundary condition + ! ! =1 use observed ice-cover ( => fill namsbc_iif ) + ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice") + ! ! except in AGRIF zoom where it has to be specified + ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges) + ! ! =F levitating ice (no pressure, mass and salt exchanges) + ! Misc. options of sbc : + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked + ! ! =1 global mean of e-p-r set to zero at each time step + ! ! =2 annual global mean of e-p-r set to zero + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .false. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave) + nn_sdrift = 0 ! Parameterization for the calculation of 3D-Stokes drift from the surface Stokes drift + ! ! = 0 Breivik 2015 parameterization: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] + ! ! = 1 Phillips: v_z=v_o*[exp(2*k*z)-beta*sqrt(-2*k*pi*z)*erfc(sqrt(-2*k*z))] + ! ! = 2 Phillips as (1) but using the wave frequency from a wave model + ln_tauwoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave) + ln_tauw = .false. ! Activate ocean stress components from wave model + ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) + nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , + ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) +/ +!----------------------------------------------------------------------- +&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the fluxes 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_utau = 'utau' , 24. , 'utau' , .false. , .false., 'yearly' , '' , '' , '' + sn_vtau = 'vtau' , 24. , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' + sn_qtot = 'qtot' , 24. , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' + sn_qsr = 'qsr' , 24. , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' + sn_emp = 'emp' , 24. , 'emp' , .false. , .false., 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .false. ! "NCAR" algorithm (Large and Yeager 2008) + ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) + ln_COARE_3p5 = .false. ! "COARE 3.5" algorithm (Edson et al. 2013) + ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) + ! + rn_zqt = 10. ! Air temperature & humidity reference height (m) + rn_zu = 10. ! Wind vector reference height (m) + ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012) + ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015) + ln_taudif = .false. ! HF tau contribution: use "mean of stress module - module of the mean stress" data + rn_pfac = 1. ! multiplicative factor for precipitation (total & snow) + rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to + ! ! calculate the wind stress (0.=absolute or 1.=relative winds) + + 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_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' + sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' + sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tdif = 'taudif_core' , 24. , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") +!----------------------------------------------------------------------- + nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data + ln_usecplmask = .false. ! 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) + ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1) + !_____________!__________________________!____________!_____________!______________________!________! + ! ! description ! multiple ! vector ! vector ! vector ! + ! ! ! categories ! reference ! orientation ! grids ! +!*** send *** + sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , '' + sn_snd_alb = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick = 'none' , 'no' , '' , '' , '' + sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' + sn_snd_co2 = 'coupled' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick1 = 'ice and snow' , 'no' , '' , '' , '' + sn_snd_mpnd = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_sstfrz = 'coupled' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'no' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'none' , 'no' , '' , '' , '' + sn_rcv_taumod = 'coupled' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , 'U,V' + sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'no' , '' , '' , '' + sn_rcv_rnf = 'coupled' , 'no' , '' , '' , '' + sn_rcv_cal = 'coupled' , 'no' , '' , '' , '' + sn_rcv_co2 = 'coupled' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'none' , 'no' , '' , '' , '' + sn_rcv_mslp = 'none' , 'no' , '' , '' , '' + sn_rcv_phioc = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfx = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfy = 'none' , 'no' , '' , '' , '' + sn_rcv_wper = 'none' , 'no' , '' , '' , '' + sn_rcv_wnum = 'none' , 'no' , '' , '' , '' + sn_rcv_wfreq = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' + sn_rcv_ts_ice = 'none' , 'no' , '' , '' , '' + sn_rcv_isf = 'none' , 'no' , '' , '' , '' + sn_rcv_icb = 'none' , 'no' , '' , '' , '' + sn_rcv_tauwoc = 'none' , 'no' , '' , '' , '' + sn_rcv_tauw = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .true. ! =T Read in file ; =F set all to 0. (see sbcssm) + ln_3d_uve = .false. ! specify whether we are supplying a 3D u,v and e3 field + ln_read_frq = .false. ! specify whether we must read frq or not + + cn_dir = './' ! root directory for the ocean 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_usp = 'sas_grid_U' , 120. , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsp = 'sas_grid_V' , 120. , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tem = 'sas_grid_T' , 120. , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sas_grid_T' , 120. , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_ssh = 'sas_grid_T' , 120. , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' + sn_e3t = 'sas_grid_T' , 120. , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' + sn_frq = 'sas_grid_T' , 120. , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the ice cover 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_ice ='ice_cover_clim.nc' , -12. ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .false. ! RGB light penetration (Red-Green-Blue) + ln_qsr_2bd = .false. ! 2BD light penetration (two bands) + ln_qsr_bio = .false. ! bio-model light penetration + ! ! RGB & 2BD choices: + rn_abs = 0.58 ! RGB & 2BD: fraction absorbed in the very near surface + rn_si0 = 0.35 ! RGB & 2BD: shortess depth of extinction + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) + rn_si1 = 23.0 ! 2BD : longest depth of extinction + + 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_sstr = 0 ! add a retroaction term to the surface heat flux (=1) or not (=0) + rn_dqdt = -40. ! magnitude of the retroaction on temperature [W/m2/K] + nn_sssr = 0 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + 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] + nn_sssr_ice = 1 ! control of sea surface restoring under sea-ice + ! 0 = no restoration under ice : * (1-icefrac) + ! 1 = restoration everywhere + ! >1 = enhanced restoration under ice : 1+(nn_icedmp-1)*icefrac + cn_dir = './' ! root directory for the SST/SSS 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_sst = 'sst_data' , 24. , 'sst' , .false. , .false., 'yearly' , '' , '' , '' + sn_sss = 'sss_data' , -1. , 'sss' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .false. ! 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 + ln_rnf_depth = .false. ! read in depth information for runoff + ln_rnf_tem = .false. ! read in temperature information for runoff + ln_rnf_sal = .false. ! read in salinity information for runoff + ln_rnf_depth_ini = .false. ! compute depth at initialisation from runoff file + rn_rnf_max = 5.735e-4 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150. ! depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) + nn_rnf_depth_file = 0 ! create (=1) a runoff depth file or not (=0) + ln_rnf_icb = .false. ! read in iceberg flux from a file (fill sn_i_rnf if .true.) + + cn_dir = './' ! root directory for the runoff 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_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' , '' , '' , '' + sn_i_rnf = 'NOT_USED' , -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000. ! reference atmospheric pressure [N/m2]/ + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .false. ! inverse barometer added to OBC ssh data + + cn_dir = './' ! root directory for the Patm 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_apr = 'patm' , -1. ,'somslpre' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_isf ! Top boundary layer (ISF) (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + ! ! type of top boundary layer + nn_isf = 1 ! ice shelf melting/freezing + ! 1 = presence of ISF ; 2 = bg03 parametrisation + ! 3 = rnf file for ISF ; 4 = ISF specified freshwater flux + ! options 1 and 4 need ln_isfcav = .true. (domzgr) + ! ! nn_isf = 1 or 2 cases: + rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula + rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) + ! ! 0 => thickness of the tbl = thickness of the first wet cell + ! ! nn_isf = 1 case + nn_isfblk = 1 ! 1 ISOMIP like: 2 equations formulation (Hunter et al., 2006) + ! ! 2 ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) + nn_gammablk = 1 ! 0 = cst Gammat (= gammat/s) + ! ! 1 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) + ! ! 2 = velocity and stability dependent Gamma (Holland et al. 1999) + + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! 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 ! +!* nn_isf = 4 case + sn_fwfisf = 'rnfisf' , -12. ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'rnfisf' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='rnfisf' , -12. ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='rnfisf' , -12. ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iscpl ! land ice / ocean coupling option (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + nn_drown = 10 ! number of iteration of the extrapolation loop (fill the new wet cells) + ln_hsb = .false. ! activate conservation module (conservation exact after a time of rn_fiscpl) + nn_fiscpl = 43800 ! (number of time step) conservation period (maybe should be fix to the coupling frequencey of restart frequency) +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- + 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_wfr = 'sdw_ecwaves_orca2' , 6. , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6. , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .false. ! activate iceberg floats (force =F with "key_agrif") + ! + ! ! diagnostics: + ln_bergdia = .true. ! Calculate budgets + nn_verbose_level = 0 ! Turn on more verbose output if level > 0 + nn_verbose_write = 15 ! Timesteps between verbose messages + nn_sample_rate = 1 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 8.8e7, 4.1e8, 3.3e9, 1.8e10, 3.8e10, 7.5e10, 1.2e11, 2.2e11, 3.9e11, 7.4e11 + ! ! Proportion of calving mass to apportion to each class + rn_distribution = 0.24, 0.12, 0.15, 0.18, 0.12, 0.07, 0.03, 0.03, 0.03, 0.02 + ! ! Ratio between effective and real iceberg mass (non-dim) + ! ! i.e. number of icebergs represented at a point + rn_mass_scaling = 2000., 200., 50., 20., 10., 5., 2., 1., 1., 1. + ! thickness of newly calved bergs (m) + rn_initial_thickness = 40., 67., 133., 175., 250., 250., 250., 250., 250., 250. + ! + rn_rho_bergs = 850. ! Density of icebergs + rn_LoW_ratio = 1.5 ! Initial ratio L/W for newly calved icebergs + ln_operator_splitting = .true. ! Use first order operator splitting for thermodynamics + rn_bits_erosion_fraction = 0. ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0. ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0. ! CFL speed limit for a berg + + cn_dir = './' ! root directory for the calving 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_icb = 'calving' , -1. ,'calvingmask', .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) +!----------------------------------------------------------------------- + ! ! free slip ! partial slip ! no slip ! strong slip + rn_shlat = -9999. ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. +/ +!----------------------------------------------------------------------- +&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 +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .false. ! Activate tides + ln_tide_pot = .true. ! use tidal potential forcing + ln_scal_load = .false. ! Use scalar approximation for + rn_scal_load = 0.094 ! load potential + ln_read_load = .false. ! Or read load potential from file + cn_tide_load = 'tide_LOAD_grid_T.nc' ! filename for load potential + ! + ln_tide_ramp = .false. ! Use linear ramp for tides at startup + rdttideramp = 0. ! ramp duration in days + clname(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .false. ! Use unstructured open boundaries + nb_bdy = 0 ! number of open boundary sets + ln_coords_file = .true. ! =T : read bdy coordinates from file + cn_coords_file = 'coordinates.bdy.nc' ! bdy coordinates files + ln_mask_file = .false. ! =T : read mask from file + cn_mask_file = '' ! name of mask file (if ln_mask_file=.TRUE.) + cn_dyn2d = 'none' ! + nn_dyn2d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! ! = 2, use tidal harmonic forcing data from files + ! ! = 3, use external data AND tidal harmonic forcing + cn_dyn3d = 'none' ! + nn_dyn3d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_tra = 'none' ! + nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_ice = 'none' ! + nn_ice_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! + ln_tra_dmp =.false. ! open boudaries conditions for tracers + ln_dyn3d_dmp =.false. ! open boundary condition for baroclinic velocities + rn_time_dmp = 1. ! Damping time scale in days + rn_time_dmp_out = 1. ! Outflow damping time scale + nn_rimwidth = 10 ! width of the relaxation zone + ln_vol = .false. ! total volume correction (see nn_volctl parameter) + nn_volctl = 1 ! = 0, the total water flux across open boundaries is zero +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data (see nam_bdy) +!----------------------------------------------------------------------- + ln_zinterp = .false. ! T if a vertical interpolation is required. Variables gdep[tuv] and e3[tuv] must exist in the file + ! ! automatically defined to T if the number of vertical levels in bdy dta /= jpk + ln_full_vel = .false. ! T if [uv]3d are "full" velocities and not only its baroclinic components + ! ! in this case, baroclinic and barotropic velocities will be recomputed -> [uv]2d not needed + ! + cn_dir = 'bdydta/' ! root directory for the BDY 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 ! + bn_ssh = 'amm12_bdyT_u2d' , 24. , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24. , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24. , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24. , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24. , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24. , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24. , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' , 24. , 'siconc' , .true. , .false., 'daily' , '' , '' , '' + bn_h_i = 'amm12_bdyT_ice' , 24. , 'sithic' , .true. , .false., 'daily' , '' , '' , '' + bn_h_s = 'amm12_bdyT_ice' , 24. , 'snthic' , .true. , .false., 'daily' , '' , '' , '' + bn_t_i = 'NOT USED' , 24. , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24. , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24. , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24. , 'sisalt' , .true. , .false., 'daily' , '' , '' , '' + ! melt ponds (be careful, bn_aip is the pond concentration (not fraction), so it differs from rn_iceapnd) + bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! -- salinity -- + rn_ice_age = 30. ! -- age -- + rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i -- + rn_ice_hpnd = 0.05 ! -- pond depth -- + rn_ice_hlid = 0.0 ! -- pond lid depth -- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries (default: OFF) +!----------------------------------------------------------------------- + filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. ! + ln_bdytide_conj = .false. ! +/ + +!!====================================================================== +!! *** 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_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot + ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) + ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ! + ln_drgimp = .true. ! implicit top/bottom friction flag + ln_drgice_imp = .false. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 1 constant flux + ! ! = 2 read variable flux [mW/m2] + rn_geoflx_cst = 86.4e-3 ! Constant value of geothermal heat 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 = .false. ! 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_teos10 = .true. ! = Use TEOS-10 + ln_eos80 = .false. ! = Use EOS80 + ln_seos = .false. ! = Use S-EOS (simplified Eq.) + ! + ! ! S-EOS coefficients (ln_seos=T): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 1.6550e-1 ! thermal expension coefficient + rn_b0 = 7.6554e-1 ! saline expension coefficient + rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 7.4914e-4 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 1.4970e-4 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.1090e-5 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 2.4341e-3 ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_OFF = .false. ! No tracer advection + ln_traadv_cen = .false. ! 2nd order centered scheme + nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_traadv_fct = .false. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + ln_traadv_mus = .false. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths + ln_traadv_ubs = .false. ! UBS scheme + nn_ubs_v = 2 ! =2 , vertical 2nd order FCT / COMPACT 4th order + ln_traadv_qck = .false. ! QUICKEST scheme +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .false. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator + ! + ! ! Direction of action: + ln_traldf_lev = .false. ! iso-level + ln_traldf_hor = .false. ! horizontal (geopotential) + ln_traldf_iso = .false. ! iso-neutral (standard operator) + ln_traldf_triad = .false. ! iso-neutral (triad operator) + ! + ! ! iso-neutral options: + ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators) + rn_slpmax = 0.01 ! slope limit (both operators) + ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only) + rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only) + ln_botmix_triad = .false. ! lateral mixing on bottom (triad only) + ! + ! ! Coefficients: + nn_aht_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing) + ! ! time invariant coefficients: aht0 = 1/2 Ud*Ld (lap case) + ! ! or = 1/12 Ud*Ld^3 (blp case) + rn_Ud = 0.01 ! 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 = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation + rn_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) + nn_mle = 1 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + rn_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) + nn_mld_uv = 0 ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + nn_conv = 0 ! =1 no MLE in case of convection ; =0 always MLE + rn_rho_c_mle = 0.01 ! delta rho criterion used to calculate MLD for FK +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_induced_velocity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.02 ! 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 =.false. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .false. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column + ! ! =1 no damping in the mixing layer (kz criteria) + ! ! =2 no damping in the mixed layer (rho crieria) + cn_resto = 'resto.nc' ! Name of file containing restoration coeff. field (use dmp_tools to create this) +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! z-star vertical coordinate + ln_vvl_ztilde = .false. ! z-tilde vertical coordinate: only high frequency variations + ln_vvl_layer = .false. ! full layer vertical coordinate + ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar + ln_vvl_zstar_at_eqtor = .false. ! ztilde near the equator + rn_ahe3 = 0.0 ! thickness diffusion coefficient + rn_rst_e3t = 30.0 ! ztilde to zstar restoration timescale [days] + rn_lf_cutoff = 5.0 ! cutoff frequency for low-pass filter [days] + rn_zdef_max = 0.9 ! maximum fractional e3t deformation + ln_vvl_dbg = .true. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .false. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .false. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! energy conserving scheme + ln_dynvor_ens = .false. ! enstrophy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_enT = .false. ! energy conserving scheme (T-point) + ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) + ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE + ! ! (f-point vorticity schemes only) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .false. ! z-coordinate - full steps + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .false. ! s-coordinate (standard jacobian formulation) + ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf + ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) + ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. ! explicit free surface + ln_dynspg_ts = .false. ! split-explicit free surface + ln_bt_fw = .true. ! Forward integration of barotropic Eqs. + ln_bt_av = .true. ! Time filtering of barotropic variables + nn_bt_flt = 1 ! Time filter choice = 0 None + ! ! = 1 Boxcar over nn_baro sub-steps + ! ! = 2 Boxcar over 2*nn_baro " " + ln_bt_auto = .true. ! Number of sub-step defined from: + rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds + rn_bt_alpha = 0. ! Temporal diffusion parameter (if ln_bt_av=F) +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) + ln_dynldf_lap = .false. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coefficient : + ! ! =-30 read in eddy_viscosity_3D.nc file + ! ! =-20 read in eddy_viscosity_2D.nc file + ! ! = 0 constant + ! ! = 10 F(k)=c1d + ! ! = 20 F(i,j)=F(grid spacing)=c2d + ! ! = 30 F(i,j,k)=c2d*c1d + ! ! = 31 F(i,j,k)=F(grid spacing and local velocity) + ! ! = 32 F(i,j,k)=F(local gridscale and deformation rate) + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.1 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) + ! ! Smagorinsky settings (nn_ahm_ijk_t= 32) : + rn_csmc = 3.5 ! Smagorinsky constant of proportionality + rn_minfac = 1.0 ! multiplier of theorectical lower limit + rn_maxfac = 1.0 ! multiplier of theorectical upper limit + ! ! iso-neutral laplacian operator (ln_dynldf_iso=T) : + rn_ahm_b = 0.0 ! background eddy viscosity [m2/s] +/ +!----------------------------------------------------------------------- +&namdta_dyn ! offline ocean input files (OFF_SRC only) +!----------------------------------------------------------------------- + ln_dynrnf = .false. ! runoffs option enabled (T) or not (F) + ln_dynrnf_depth = .false. ! runoffs is spread in vertical (T) or not (F) +! fwbcorr = 3.786e-06 ! annual global mean of empmr for ssh correction + + cn_dir = './' ! root directory for the ocean 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 = 'dyna_grid_T' , 120. , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120. , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120. , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120. , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120. , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120. , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120. , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120. , 'sobblcoy' , .true. , .true. , 'yearly' , '' , '' , '' +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! adaptive-implicit vertical advection + ln_zad_Aimp = .false. ! Courant number dependent scheme (Shchepetkin 2015) + ! + ! ! type of vertical closure (required) + ln_zdfcst = .false. ! constant mixing + ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) + ln_zdftke = .false. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfgls = .false. ! Generic Length Scale closure (T => fill namzdf_gls) + ln_zdfosm = .false. ! OSMOSIS BL closure (T => fill namzdf_osm) + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + nn_evdm = 0 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! mixing coefficient [m2/s] + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + nn_npc = 1 ! frequency of application of npc + nn_npcp = 365 ! npc control print frequency + ! + ln_zdfddm = .false. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ! + ! ! gravity wave-driven vertical mixing + ln_zdfiwm = .false. ! internal wave-induced mixing (T => fill namzdf_iwm) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 100.e-4 ! maximum value of the vertical viscosity + rn_alp = 5. ! coefficient of the parameterization + nn_ric = 2 ! coefficient of the parameterization + ln_mldw = .false. ! enhanced mixing in the Ekman layer + rn_ekmfc = 0.7 ! Factor in the Ekman depth Equation + rn_mldmin = 1.0 ! minimum allowable mixed-layer depth estimate (m) + rn_mldmax = 1000.0 ! maximum allowable mixed-layer depth estimate (m) + rn_wtmix = 10.0 ! vertical eddy viscosity coeff [m2/s] in the mixed-layer + rn_wvmix = 10.0 ! vertical eddy diffusion coeff [m2/s] in the mixed-layer +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + rn_ediff = 0.1 ! coef. for vertical eddy coef. (avt=rn_ediff*mxl*sqrt(e) ) + rn_ediss = 0.7 ! coef. of the Kolmogoroff dissipation + rn_ebb = 67.83 ! coef. of the surface input of tke (=67.83 suggested when ln_mxl0=T) + rn_emin = 1.e-6 ! minimum value of tke [m2/s2] + rn_emin0 = 1.e-4 ! surface minimum value of tke [m2/s2] + rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it) + nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm) + 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 + ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) + nn_mxlice = 2 ! type of scaling under sea-ice + ! = 0 no scaling under sea-ice + ! = 1 scaling with constant sea-ice thickness + ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) + ! = 3 scaling with maximum sea-ice thickness + rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) + rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value + ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002) + rn_lc = 0.15 ! coef. associated to Langmuir cells + 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) + rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) + nn_htau = 1 ! type of exponential decrease of tke penetration below the ML + ! = 0 constant 10 m length scale + ! = 1 0.5m at the equator to 30m poleward of 40 degrees + nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice + ! ! = 0 no impact of ice cover on langmuir & surface wave breaking + ! ! = 1 weigthed by 1-TANH(10*fr_i) + ! ! = 2 weighted by 1-fr_i + ! ! = 3 weighted by 1-MIN(1,4*fr_i) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1.e-7 ! minimum value of e [m2/s2] + rn_epsmin = 1.e-12 ! minimum value of eps [m2/s3] + ln_length_lim = .true. ! limit on the dissipation rate under stable stratification (Galperin et al., 1988) + rn_clim_galp = 0.267 ! galperin limit + ln_sigpsi = .true. ! Activate or not Burchard 2001 mods on psi schmidt number in the wb case + rn_crban = 100. ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000. ! Charnock constant for wb induced roughness length + rn_hsro = 0.02 ! Minimum surface roughness + rn_hsri = 0.03 ! Ice-ocean roughness + rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1) + nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) + ! ! = 3 requires ln_wave=T + nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice + ! ! = 0 no impact of ice cover + ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i) + ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i + ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i) + nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum) + nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum) + nn_stab_func = 2 ! stability function (0=Galp, 1= KC94, 2=CanutoA, 3=CanutoB) + nn_clos = 1 ! predefined closure type (0=MY82, 1=k-eps, 2=k-w, 3=Gen) +/ +!----------------------------------------------------------------------- +&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) +!----------------------------------------------------------------------- + ln_use_osm_la = .false. ! Use namelist rn_osm_la + rn_osm_la = 0.3 ! Turbulent Langmuir number + rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) + nn_ave = 0 ! choice of horizontal averaging on avt, avmu, avmv + ln_dia_osm = .true. ! output OSMOSIS-OBL variables + rn_osm_hbl0 = 10. ! initial hbl value + ln_kpprimix = .true. ! Use KPP-style Ri# mixing below BL + rn_riinfty = 0.7 ! Highest local Ri_g permitting shear instability + rn_difri = 0.005 ! max Ri# diffusivity at Ri_g = 0 (m^2/s) + ln_convmix = .true. ! Use convective instability mixing below BL + rn_difconv = 1. ! diffusivity when unstable below BL (m2/s) + nn_osm_wave = 0 ! Method used to calculate Stokes drift + ! ! = 2: Use ECMWF wave fields + ! ! = 1: Pierson Moskowitz wave spectrum + ! ! = 0: Constant La# = 0.3 +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) + ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency + ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) +/ + +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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_diaharm Harmonic analysis of tidal constituents (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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtrd ! trend diagnostics (default: OFF) +!----------------------------------------------------------------------- + ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE + ln_dyn_trd = .false. ! (T) 3D momentum trend output + ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet) + ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet) + ln_KE_trd = .false. ! (T) 3D Kinetic Energy trends + ln_PE_trd = .false. ! (T) 3D Potential Energy trends + ln_tra_trd = .false. ! (T) 3D tracer trend output + ln_tra_mxl = .false. ! (T) 2D tracer trends averaged over the mixed layer (not coded yet) + nn_trd = 365 ! print frequency (ln_glo_trd=T) (unit=time step) +/ +!!gm nn_ctls = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) +!!gm cn_trdrst_in = "restart_mld" ! suffix of ocean restart name (input) +!!gm cn_trdrst_out = "restart_mld" ! suffix of ocean restart name (output) +!!gm ln_trdmld_restart = .false. ! restart for ML diagnostics +!!gm ln_trdmld_instant = .false. ! flag to diagnose trends of instantantaneous or mean ML T/S +!!gm +!----------------------------------------------------------------------- +&namptr ! Poleward Transport Diagnostic (default: OFF) +!----------------------------------------------------------------------- + ln_diaptr = .false. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .false. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .false. ! output the heat and salt budgets (T) or not (F) +/ +!----------------------------------------------------------------------- +&namdiu ! Cool skin and warm layer models (default: OFF) +!----------------------------------------------------------------------- + ln_diurnal = .false. ! + ln_diurnal_only = .false. ! +/ +!----------------------------------------------------------------------- +&namflo ! float parameters (default: OFF) +!----------------------------------------------------------------------- + ln_floats = .false. ! activate floats or not + jpnfl = 1 ! total number of floats during the run + jpnnewflo = 0 ! number of floats for the restart + ln_rstflo = .false. ! float restart (T) or not (F) + nn_writefl = 75 ! frequency of writing in float output file + nn_stockfl = 5475 ! frequency of creation of the float restart file + ln_argo = .false. ! Argo type floats (stay at the surface each 10 days) + ln_flork4 = .false. ! trajectories computed with a 4th order Runge-Kutta (T) + ! ! or computed with Blanke' scheme (F) + ln_ariane = .true. ! Input with Ariane tool convention(T) + ln_flo_ascii= .true. ! Output with Ariane tool netcdf convention(F) or ascii file (T) +/ +!----------------------------------------------------------------------- +&nam_diaharm ! Harmonic analysis of tidal constituents (default: OFF) +!----------------------------------------------------------------------- + ln_diaharm = .false. ! Choose tidal harmonic output or not + nit000_han = 1 ! First time step used for harmonic analysis + nitend_han = 75 ! Last time step used for harmonic analysis + nstep_han = 15 ! Time step frequency for harmonic analysis + tname(1) = 'M2' ! Name of tidal constituents + tname(2) = 'K1' ! --- +/ +!----------------------------------------------------------------------- +&nam_diadct ! transports through some sections (default: OFF) +!----------------------------------------------------------------------- + ln_diadct = .false. ! Calculate transport thru sections or not + nn_dct = 15 ! time step frequency for transports computing + nn_dctwri = 15 ! time step frequency for transports writing + nn_secdebug = 112 ! 0 : no section to debug + ! ! -1 : debug all section + ! ! 0 < n : debug section number n +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default: OFF) +!----------------------------------------------------------------------- + ln_dia25h = .false. ! Choose 25h mean output or not +/ +!----------------------------------------------------------------------- +&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") +!----------------------------------------------------------------------- + nn_nchunks_i = 4 ! number of chunks in i-dimension + nn_nchunks_j = 4 ! number of chunks in j-dimension + nn_nchunks_k = 31 ! number of chunks in k-dimension + ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which + ! ! is optimal for postprocessing which works exclusively with horizontal slabs + ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression + ! ! (F) ignore chunking information and produce netcdf3-compatible files +/ + +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!----------------------------------------------------------------------- +&namobs ! observation usage switch (default: OFF) +!----------------------------------------------------------------------- + ln_diaobs = .false. ! Logical switch for the observation operator + ! + ln_t3d = .false. ! Logical switch for T profile observations + ln_s3d = .false. ! Logical switch for S profile observations + ln_sla = .false. ! Logical switch for SLA observations + ln_sst = .false. ! Logical switch for SST observations + ln_sss = .false. ! Logical swithc for SSS observations + ln_sic = .false. ! Logical switch for Sea Ice observations + ln_vel3d = .false. ! Logical switch for velocity observations + ln_altbias = .false. ! Logical switch for altimeter bias correction + ln_sstbias = .false. ! Logical switch for SST bias correction + ln_nea = .false. ! Logical switch for rejection of observations near land + ln_grid_global = .true. ! Logical switch for global distribution of observations + ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table + ln_ignmis = .true. ! Logical switch for ignoring missing files + ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there + ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs + ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. + ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres + ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres + ln_sss_fp_indegs = .true. ! Logical for SSS: T=> averaging footprint is in degrees, F=> in metres + ln_sic_fp_indegs = .true. ! Logical for SIC: T=> averaging footprint is in degrees, F=> in metres +! All of the *files* variables below are arrays. Use namelist_cfg to add more files + cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names + cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names + cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names + cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names + cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names + cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names + cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name + cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file name + cn_gridsearchfile ='gridsearch.nc' ! Grid search file name + rn_gridsearchres = 0.5 ! Grid search resolution + rn_mdtcorr = 1.61 ! MDT correction + rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction + rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) + nn_1dint = 0 ! Type of vertical interpolation method + nn_2dint = 0 ! Default horizontal interpolation method + nn_2dint_sla = 0 ! Horizontal interpolation method for SLA + nn_2dint_sst = 0 ! Horizontal interpolation method for SST + nn_2dint_sss = 0 ! Horizontal interpolation method for SSS + nn_2dint_sic = 0 ! Horizontal interpolation method for SIC + nn_msshc = 0 ! MSSH correction scheme + nn_profdavtypes = -1 ! Profile daily average types - array +/ +!----------------------------------------------------------------------- +&nam_asminc ! assimilation increments ('key_asminc') +!----------------------------------------------------------------------- + ln_bkgwri = .false. ! Logical switch for writing out background state + ln_trainc = .false. ! Logical switch for applying tracer increments + ln_dyninc = .false. ! Logical switch for applying velocity increments + ln_sshinc = .false. ! Logical switch for applying SSH increments + ln_asmdin = .false. ! Logical switch for Direct Initialization (DI) + ln_asmiau = .false. ! Logical switch for Incremental Analysis Updating (IAU) + nitbkg = 0 ! Timestep of background in [0,nitend-nit000-1] + nitdin = 0 ! Timestep of background for DI in [0,nitend-nit000-1] + nitiaustr = 1 ! Timestep of start of IAU interval in [0,nitend-nit000-1] + nitiaufin = 15 ! Timestep of end of IAU interval in [0,nitend-nit000-1] + niaufn = 0 ! Type of IAU weighting function + ln_salfix = .false. ! Logical switch for ensuring that the sa > salfixmin + salfixmin = -9999 ! Minimum salinity after applying the increments + nn_divdmp = 0 ! Number of iterations of divergence damping operator +/ + +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_listonly = .false. ! do nothing else than listing the best domain decompositions (with land domains suppression) + ! ! if T: the largest number of cores tested is defined by max(mppsize, jpni*jpnj) + ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold + jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T + sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following + sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings. + sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure + sn_cfctl%l_oceout = .FALSE. ! that all areas report. + sn_cfctl%l_layout = .FALSE. ! + sn_cfctl%l_mppout = .FALSE. ! + sn_cfctl%l_mpptop = .FALSE. ! + sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0] + sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000] + sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1] + sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info + nn_print = 0 ! level of print (0 no extra print) + nn_ictls = 0 ! start i indice of control sum (use to compare mono versus + nn_ictle = 0 ! end i indice of control sum multi processor runs + nn_jctls = 0 ! start j indice of control over a subdomain) + nn_jctle = 0 ! end j indice of control + nn_isplt = 1 ! number of processors in i-direction + nn_jsplt = 1 ! number of processors in j-direction + ln_timing = .false. ! timing by routine write out in timing.output file + ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- + ln_sto_eos = .false. ! stochastic equation of state + nn_sto_eos = 1 ! number of independent random walks + rn_eos_stdxy = 1.4 ! random walk horz. standard deviation (in grid points) + rn_eos_stdz = 0.7 ! random walk vert. standard deviation (in grid points) + rn_eos_tcor = 1440. ! random walk time correlation (in timesteps) + nn_eos_ord = 1 ! order of autoregressive processes + nn_eos_flt = 0 ! passes of Laplacian filter + rn_eos_lim = 2.0 ! limitation factor (default = 3.0) + ln_rststo = .false. ! start from mean parameter (F) or from restart file (T) + ln_rstseed = .true. ! read seed of RNG from restart file + cn_storst_in = "restart_sto" ! suffix of stochastic parameter restart file (input) + cn_storst_out = "restart_sto" ! suffix of stochastic parameter restart file (output) +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/context_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/context_nemo.xml new file mode 100644 index 0000000..a12b8bd --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/context_nemo.xml @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/domain_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/domain_def_nemo.xml new file mode 100644 index 0000000..0931e2b --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/domain_def_nemo.xml @@ -0,0 +1,198 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/field_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/field_def_nemo-oce.xml new file mode 100644 index 0000000..62b0bb6 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/field_def_nemo-oce.xml @@ -0,0 +1,1129 @@ + + + + + + + + + + + + + + + + + + + + + + + toce_pot * e3t + + soce_pra * e3t + + + toce_con * e3t + + soce_abs * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + sst_pot * sst_pot + + + + + + + + + + + + sss_pra * sss_pra + + + + + + + sst_con * sst_con + + + + + + + + + + + + sss_abs * sss_abs + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + uoce * uoce * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + voce * voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + ut * e3u + + us * e3u + + urhop * e3u + + vt * e3v + + vs * e3v + + vrhop * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + @voce_e3v + + this * e1v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sophtvtr - sophtove + sophtvtr - sopstove + + + + + + + + + + + + + + + + + + + ttrd_atf * e3t + strd_atf * e3t + + ttrd_atf_e3t * 1026.0 * 3991.86795711963 + strd_atf_e3t * 1026.0 * 0.001 + + + + + + + + + + + sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) + sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) + + + + + + + + + + + + + ttrd_ldf + ttrd_zdf - ttrd_zdfp + strd_ldf + strd_zdf - strd_zdfp + + + + + + + + + + + + + + + + + ttrd_xad * e3t + strd_xad * e3t + ttrd_yad * e3t + strd_yad * e3t + ttrd_zad * e3t + strd_zad * e3t + ttrd_ad * e3t + strd_ad * e3t + ttrd_totad * e3t + strd_totad * e3t + ttrd_ldf * e3t + strd_ldf * e3t + ttrd_zdf * e3t + strd_zdf * e3t + ttrd_evd * e3t + strd_evd * e3t + + + ttrd_iso * e3t + strd_iso * e3t + ttrd_zdfp * e3t + strd_zdfp * e3t + + + ttrd_dmp * e3t + strd_dmp * e3t + ttrd_bbl * e3t + strd_bbl * e3t + ttrd_npc * e3t + strd_npc * e3t + ttrd_qns * e3ts + strd_cdt * e3ts + ttrd_qsr * e3t + ttrd_bbc * e3t + + + ttrd_totad_e3t * 1026.0 * 3991.86795711963 + strd_totad_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + ttrd_iso_e3t * 1026.0 * 3991.86795711963 + strd_iso_e3t * 1026.0 * 0.001 + ttrd_zdfp_e3t * 1026.0 * 3991.86795711963 + strd_zdfp_e3t * 1026.0 * 0.001 + ttrd_qns_e3t * 1026.0 * 3991.86795711963 + ttrd_qsr_e3t * 1026.0 * 3991.86795711963 + ttrd_bbl_e3t * 1026.0 * 3991.86795711963 + strd_bbl_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + + + + + + + + + ttrd_tot * e3t + strd_tot * e3t + + ttrd_tot_e3t * 1026.0 * 3991.86795711963 + strd_tot_e3t * 1026.0 * 0.001 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/field_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/field_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/file_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/file_def_nemo-oce.xml new file mode 100644 index 0000000..c752ddb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/file_def_nemo-oce.xml @@ -0,0 +1,52 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/file_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/file_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/grid_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/grid_def_nemo.xml new file mode 100644 index 0000000..b370feb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/grid_def_nemo.xml @@ -0,0 +1,180 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/iodef.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/iodef.xml new file mode 100644 index 0000000..8bfff14 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/iodef.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + -1 + true + false + oceanx + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/myscript_wrapper.sh b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/myscript_wrapper.sh new file mode 100755 index 0000000..87e905e --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/myscript_wrapper.sh @@ -0,0 +1,7 @@ +#!/bin/ksh +# +set -A map ./xios_server.exe ./nemo +exec_map=( 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) +# +exec ${map[${exec_map[$SLURM_PROCID]}]} +## diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/namelist_cfg b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/namelist_cfg new file mode 100644 index 0000000..8a10f62 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/namelist_cfg @@ -0,0 +1,364 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! AMM12 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = "AMMSURGE" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 1920 ! 52560 ! last time step (std 1 day = 144) + nn_date0 = 20130101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_leapy = 1 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + cn_ocerst_in = "ammsurge_restart_oce" ! suffix of ocean restart name (input) + cn_ocerst_out = "restart_oce_out" ! suffix of ocean restart name (input) + nn_stock = 52560 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 10 ! 52560 ! frequency of write in the output file (modulo referenced to nit000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 450. ! time step for the dynamics (and tracer if nn_acc=0) + ln_2d = .true. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: user defined GYRE) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + cn_domcfg = "amm7_surge_domain_cfg" ! domain configuration filename +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells +/ +!!====================================================================== +!! *** 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 (surface module) (default: NO selection) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of SBC module call + ln_usr = .true. + ln_flx = .false. ! flux formulation (T => fill namsbc_flx) + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) +/ +!----------------------------------------------------------------------- +&namsbc_usr ! namsbc_surge surge model fluxes +!----------------------------------------------------------------------- + ln_use_sbc = .false. ! (T) to turn on surge fluxes (wind and pressure only) + ! (F) for no fluxes (ie tide only case) + +! +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! + sn_wndi = 'windspd_u_amm7' , 1 ,'x_wind', .true. , .false. , 'daily' ,'' , '' + sn_wndj = 'windspd_v_amm7' , 1 ,'y_wind', .true. , .false. , 'daily' ,'' , '' + cn_dir = './fluxes/' ! root directory for the location of the bulk files + rn_vfac = 1. ! multiplicative factor for ocean/ice velocity + ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) + rn_charn_const = 0.0275 +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101200. ! reference atmospheric pressure [N/m2] + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .true. ! inverse barometer added to OBC ssh data + + cn_dir = './fluxes/' ! root directory for the Patm 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_apr = 'pressure_amm7', 1 , 'air_pressure_at_sea_level' , .true. , .false., 'daily' , '' , '' , '' +/ +!!====================================================================== +!! *** 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 = 0 ! free slip +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .true. + clname(1) = 'M2' ! name of constituent + clname(2) = 'S2' + clname(3) = 'K2' +! clname(1) ='2N2' +! clname(2)='EPS2' +! clname(3)='J1' +! clname(4)='K1' +! clname(5)='K2' +! clname(6)='L2' +! clname(7)='LA2' +! clname(8)='M2' +! clname(9)='M3' +! clname(10)='M4' +! clname(11)='M6' +! clname(12)='M8' +! clname(13)='MF' +! clname(14)='MKS2' +! clname(15)='MM' +! clname(16)='MN4' +! clname(17)='MS4' +! clname(18)='MSF' +! clname(19)='MSQM' +! clname(20)='MTM' +! clname(21)='MU2' +! clname(22)='N2' +! clname(23)='N4' +! clname(24)='NU2' +! clname(25)='O1' +! clname(26)='P1' +! clname(27)='Q1' +! clname(28)='R2' +! clname(29)='S1' +! clname(30)='S2' +! clname(31)='S4' +! clname(32)='SA' +! clname(33)='SSA' +! clname(34)='T2' +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .true. + nb_bdy = 1 ! number of open boundary sets + cn_dyn2d = 'flather' ! + nn_dyn2d_dta = 2 ! = 0, bdy data are equal to the initial state + ! = 1, bdy data are read in 'bdydata .nc' files + ! = 2, use tidal harmonic forcing data from files + ! = 3, use external data AND tidal harmonic forcing +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries +!----------------------------------------------------------------------- + filtide = 'bdydta/AMM7_surge_bdytide_rotT_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!! !! +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T) +!! namdrg_bot bottom friction (ln_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_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction +!----------------------------------------------------------------------- + rn_Cd0 = 2.4e-3 ! 1e-5 (Clare 4Jan24) ! drag coefficient [-] + rn_ke0 = 0.0e0 ! background kinetic energy [m2/s2] (non-linear cases) + ln_boost = .true., + rn_boost = 1., +/ +!!====================================================================== +!! 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_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) +/ +!----------------------------------------------------------------------- +&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 scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .true. ! Number of sub-step defined from: +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_blp = .true. ! bilaplacian operator + ln_dynldf_lap = .false. ! bilaplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = 0 ! =0 constant = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.012 ! lateral viscous velocity [m/s] + rn_Lv = 1.e+4 ! lateral viscous length [m] +/ +!!====================================================================== +!! 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 (default: NO selection) +!----------------------------------------------------------------------- + rn_avm0 = 0.1e-6 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.1e-6 ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_charn = 100000. ! Charnock constant for wb induced roughness length + nn_z0_met = 1 ! Method for surface roughness computation (0/1/2) +/ +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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 ("key_float") +!! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") +!! namdct transports through some sections ("key_diadct") +!! nam_diatmb Top Middle Bottom Output (default: OFF) +!! nam_dia25h 25h Mean Output (default: OFF) +!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_diatmb ! Top Middle Bottom Output (default F) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default F) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .false. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/namelist_ref b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/namelist_ref new file mode 100644 index 0000000..f962f37 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/namelist_ref @@ -0,0 +1,1386 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : Reference namelist_ref !! +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : 1 - Domain & run manager (namrun, namcfg, namdom, namtsd, namcrs, namc1d, namc1d_uvd) +!! namelists 2 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_cpl, +!! namsbc_sas, namtra_qsr, namsbc_rnf, +!! namsbc_isf, namsbc_iscpl, namsbc_apr, +!! namsbc_ssr, namsbc_wave, namberg) +!! 3 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide) +!! 4 - top/bot boundary (namdrg, namdrg_top, namdrg_bot, nambbc, nambbl) +!! 5 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_eiv, namtra_dmp) +!! 6 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) +!! 7 - Vertical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_gls, namzdf_iwm) +!! 8 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb) +!! 9 - Obs & Assim (namobs, nam_asminc) +!! 10 - miscellaneous (nammpp, namctl, namsto) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!!====================================================================== +!! *** 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! Assimilation cycle index + cn_exp = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5840) + nn_date0 = 010101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_time0 = 0 ! initial time of day in hhmm + nn_leapy = 0 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T + nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T + ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist + ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart + ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "." ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "." ! directory in which to write output ocean restarts + ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model + nn_istate = 0 ! output the initial state (1) or not (0) + ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) + nn_stock = 0 ! used only if ln_rst_list = F: output restart freqeuncy (modulo referenced to 1) + ! ! = 0 force to write restart files only at the end of the run + ! ! = -1 do not do any restart + nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written + nn_write = 0 ! used only if key_iomput is not defined: output frequency (modulo referenced to nn_it000) + ! ! = 0 force to write output files only at the end of the run + ! ! = -1 do not do any output file + ln_mskland = .false. ! mask land points in NetCDF outputs + ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + ln_xios_read = .FALSE. ! use XIOS to read restart file (only for a single file restart) + nn_wxios = 0 ! use XIOS to write restart file 0 - no, 1 - single file output, 2 - multiple file output + ln_rst_eos = .TRUE. ! check if the equation of state used to produce the restart is consistent with model +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.00 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 5400. ! time step for the dynamics and tracer + rn_atfp = 0.1 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_2d = .false. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration (F => create/check namusr_def) + cn_domcfg = "domain_cfg" ! domain configuration filename + ! + ln_closea = .false. ! T => keep closed seas (defined by closea_mask field) in the + ! ! domain and apply special treatment of freshwater fluxes. + ! ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. + ! ! If closea_mask field doesn't exist in the domain_cfg file + ! ! then this logical does nothing. + ln_write_cfg = .false. ! (=T) create the domain configuration file + cn_domcfg_out = "domain_cfg_out" ! newly created domain configuration filename + ! + ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present + ! ! in netcdf input files, as the start j-row for reading +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .false. ! ocean initialisation + ln_tsd_dmp = .false. ! 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' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_il = .false. ! T/F activation of iterative limiter + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells + rn_wdld = 2.5 ! Land elevation below which WaD is allowed + nn_wdit = 20 ! Max iterations for WaD limiter + rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes + rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) +/ +!----------------------------------------------------------------------- +&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T) +!----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_binref = 0 ! Bin centering preference: NORTH or EQUAT + ! ! 0, coarse grid is binned with preferential treatment of the north fold + ! ! 1, coarse grid is binned with centering at the equator + ! ! Symmetry with nn_facty being odd-numbered. Asymmetry with even-numbered nn_facty. + ln_msh_crs = .false. ! =T create a mesh & mask file + nn_crs_kz = 0 ! 0, MEAN of volume boxes + ! ! 1, MAX of boxes + ! ! 2, MIN of boxes + ln_crs_wn = .true. ! wn coarsened (T) or computed using horizontal divergence ( F ) +/ +!----------------------------------------------------------------------- +&namc1d ! 1D configuration options ("key_c1d" default: PAPA station) +!----------------------------------------------------------------------- + rn_lat1d = 50 ! Column latitude + rn_lon1d = -145 ! Column longitude + ln_c1d_locpt = .true. ! Localization of 1D config in a grid (T) or independant point (F) +/ +!----------------------------------------------------------------------- +&namc1d_dyndmp ! U & V newtonian damping ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ln_dyndmp = .false. ! add a damping term (T) or not (F) +/ +!----------------------------------------------------------------------- +&namc1d_uvd ! data: U & V currents ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ! ! =T read U-V fields for: + ln_uvd_init = .false. ! ocean initialisation + ln_uvd_dyndmp = .false. ! U-V restoring + + cn_dir = './' ! root directory for the U-V 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_ucur = 'ucurrent' , -1. ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' + sn_vcur = 'vcurrent' , -1. ,'v_current', .false. , .true. , 'monthly' , '' , 'Vme' , '' +/ + +!!====================================================================== +!! *** 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 = 2 ! frequency of SBC module call + ! ! (control sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_usr = .false. ! user defined formulation (T => check usrdef_sbc) + ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + ! ! Type of coupling (Ocean/Ice/Atmosphere) : + ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) + ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) + nn_components = 0 ! configuration of the opa-sas OASIS coupling + ! ! =0 no opa-sas OASIS coupling: default single executable config. + ! ! =1 opa-sas OASIS coupling: multi executable config., OPA component + ! ! =2 opa-sas OASIS coupling: multi executable config., SAS component + ! Sea-ice : + nn_ice = 0 ! =0 no ice boundary condition + ! ! =1 use observed ice-cover ( => fill namsbc_iif ) + ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice") + ! ! except in AGRIF zoom where it has to be specified + ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges) + ! ! =F levitating ice (no pressure, mass and salt exchanges) + ! Misc. options of sbc : + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked + ! ! =1 global mean of e-p-r set to zero at each time step + ! ! =2 annual global mean of e-p-r set to zero + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .false. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave) + nn_sdrift = 0 ! Parameterization for the calculation of 3D-Stokes drift from the surface Stokes drift + ! ! = 0 Breivik 2015 parameterization: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] + ! ! = 1 Phillips: v_z=v_o*[exp(2*k*z)-beta*sqrt(-2*k*pi*z)*erfc(sqrt(-2*k*z))] + ! ! = 2 Phillips as (1) but using the wave frequency from a wave model + ln_tauwoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave) + ln_tauw = .false. ! Activate ocean stress components from wave model + ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) + nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , + ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) +/ +!----------------------------------------------------------------------- +&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the fluxes 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_utau = 'utau' , 24. , 'utau' , .false. , .false., 'yearly' , '' , '' , '' + sn_vtau = 'vtau' , 24. , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' + sn_qtot = 'qtot' , 24. , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' + sn_qsr = 'qsr' , 24. , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' + sn_emp = 'emp' , 24. , 'emp' , .false. , .false., 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .false. ! "NCAR" algorithm (Large and Yeager 2008) + ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) + ln_COARE_3p5 = .false. ! "COARE 3.5" algorithm (Edson et al. 2013) + ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) + ! + rn_zqt = 10. ! Air temperature & humidity reference height (m) + rn_zu = 10. ! Wind vector reference height (m) + ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012) + ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015) + ln_taudif = .false. ! HF tau contribution: use "mean of stress module - module of the mean stress" data + rn_pfac = 1. ! multiplicative factor for precipitation (total & snow) + rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to + ! ! calculate the wind stress (0.=absolute or 1.=relative winds) + + 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_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' + sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' + sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tdif = 'taudif_core' , 24. , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") +!----------------------------------------------------------------------- + nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data + ln_usecplmask = .false. ! 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) + ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1) + !_____________!__________________________!____________!_____________!______________________!________! + ! ! description ! multiple ! vector ! vector ! vector ! + ! ! ! categories ! reference ! orientation ! grids ! +!*** send *** + sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , '' + sn_snd_alb = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick = 'none' , 'no' , '' , '' , '' + sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' + sn_snd_co2 = 'coupled' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick1 = 'ice and snow' , 'no' , '' , '' , '' + sn_snd_mpnd = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_sstfrz = 'coupled' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'no' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'none' , 'no' , '' , '' , '' + sn_rcv_taumod = 'coupled' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , 'U,V' + sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'no' , '' , '' , '' + sn_rcv_rnf = 'coupled' , 'no' , '' , '' , '' + sn_rcv_cal = 'coupled' , 'no' , '' , '' , '' + sn_rcv_co2 = 'coupled' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'none' , 'no' , '' , '' , '' + sn_rcv_mslp = 'none' , 'no' , '' , '' , '' + sn_rcv_phioc = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfx = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfy = 'none' , 'no' , '' , '' , '' + sn_rcv_wper = 'none' , 'no' , '' , '' , '' + sn_rcv_wnum = 'none' , 'no' , '' , '' , '' + sn_rcv_wfreq = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' + sn_rcv_ts_ice = 'none' , 'no' , '' , '' , '' + sn_rcv_isf = 'none' , 'no' , '' , '' , '' + sn_rcv_icb = 'none' , 'no' , '' , '' , '' + sn_rcv_tauwoc = 'none' , 'no' , '' , '' , '' + sn_rcv_tauw = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .true. ! =T Read in file ; =F set all to 0. (see sbcssm) + ln_3d_uve = .false. ! specify whether we are supplying a 3D u,v and e3 field + ln_read_frq = .false. ! specify whether we must read frq or not + + cn_dir = './' ! root directory for the ocean 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_usp = 'sas_grid_U' , 120. , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsp = 'sas_grid_V' , 120. , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tem = 'sas_grid_T' , 120. , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sas_grid_T' , 120. , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_ssh = 'sas_grid_T' , 120. , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' + sn_e3t = 'sas_grid_T' , 120. , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' + sn_frq = 'sas_grid_T' , 120. , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the ice cover 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_ice ='ice_cover_clim.nc' , -12. ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .false. ! RGB light penetration (Red-Green-Blue) + ln_qsr_2bd = .false. ! 2BD light penetration (two bands) + ln_qsr_bio = .false. ! bio-model light penetration + ! ! RGB & 2BD choices: + rn_abs = 0.58 ! RGB & 2BD: fraction absorbed in the very near surface + rn_si0 = 0.35 ! RGB & 2BD: shortess depth of extinction + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) + rn_si1 = 23.0 ! 2BD : longest depth of extinction + + 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_sstr = 0 ! add a retroaction term to the surface heat flux (=1) or not (=0) + rn_dqdt = -40. ! magnitude of the retroaction on temperature [W/m2/K] + nn_sssr = 0 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + 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] + nn_sssr_ice = 1 ! control of sea surface restoring under sea-ice + ! 0 = no restoration under ice : * (1-icefrac) + ! 1 = restoration everywhere + ! >1 = enhanced restoration under ice : 1+(nn_icedmp-1)*icefrac + cn_dir = './' ! root directory for the SST/SSS 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_sst = 'sst_data' , 24. , 'sst' , .false. , .false., 'yearly' , '' , '' , '' + sn_sss = 'sss_data' , -1. , 'sss' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .false. ! 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 + ln_rnf_depth = .false. ! read in depth information for runoff + ln_rnf_tem = .false. ! read in temperature information for runoff + ln_rnf_sal = .false. ! read in salinity information for runoff + ln_rnf_depth_ini = .false. ! compute depth at initialisation from runoff file + rn_rnf_max = 5.735e-4 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150. ! depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) + nn_rnf_depth_file = 0 ! create (=1) a runoff depth file or not (=0) + ln_rnf_icb = .false. ! read in iceberg flux from a file (fill sn_i_rnf if .true.) + + cn_dir = './' ! root directory for the runoff 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_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' , '' , '' , '' + sn_i_rnf = 'NOT_USED' , -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000. ! reference atmospheric pressure [N/m2]/ + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .false. ! inverse barometer added to OBC ssh data + + cn_dir = './' ! root directory for the Patm 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_apr = 'patm' , -1. ,'somslpre' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_isf ! Top boundary layer (ISF) (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + ! ! type of top boundary layer + nn_isf = 1 ! ice shelf melting/freezing + ! 1 = presence of ISF ; 2 = bg03 parametrisation + ! 3 = rnf file for ISF ; 4 = ISF specified freshwater flux + ! options 1 and 4 need ln_isfcav = .true. (domzgr) + ! ! nn_isf = 1 or 2 cases: + rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula + rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) + ! ! 0 => thickness of the tbl = thickness of the first wet cell + ! ! nn_isf = 1 case + nn_isfblk = 1 ! 1 ISOMIP like: 2 equations formulation (Hunter et al., 2006) + ! ! 2 ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) + nn_gammablk = 1 ! 0 = cst Gammat (= gammat/s) + ! ! 1 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) + ! ! 2 = velocity and stability dependent Gamma (Holland et al. 1999) + + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! 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 ! +!* nn_isf = 4 case + sn_fwfisf = 'rnfisf' , -12. ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'rnfisf' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='rnfisf' , -12. ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='rnfisf' , -12. ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iscpl ! land ice / ocean coupling option (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + nn_drown = 10 ! number of iteration of the extrapolation loop (fill the new wet cells) + ln_hsb = .false. ! activate conservation module (conservation exact after a time of rn_fiscpl) + nn_fiscpl = 43800 ! (number of time step) conservation period (maybe should be fix to the coupling frequencey of restart frequency) +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- + 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_wfr = 'sdw_ecwaves_orca2' , 6. , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6. , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .false. ! activate iceberg floats (force =F with "key_agrif") + ! + ! ! diagnostics: + ln_bergdia = .true. ! Calculate budgets + nn_verbose_level = 0 ! Turn on more verbose output if level > 0 + nn_verbose_write = 15 ! Timesteps between verbose messages + nn_sample_rate = 1 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 8.8e7, 4.1e8, 3.3e9, 1.8e10, 3.8e10, 7.5e10, 1.2e11, 2.2e11, 3.9e11, 7.4e11 + ! ! Proportion of calving mass to apportion to each class + rn_distribution = 0.24, 0.12, 0.15, 0.18, 0.12, 0.07, 0.03, 0.03, 0.03, 0.02 + ! ! Ratio between effective and real iceberg mass (non-dim) + ! ! i.e. number of icebergs represented at a point + rn_mass_scaling = 2000., 200., 50., 20., 10., 5., 2., 1., 1., 1. + ! thickness of newly calved bergs (m) + rn_initial_thickness = 40., 67., 133., 175., 250., 250., 250., 250., 250., 250. + ! + rn_rho_bergs = 850. ! Density of icebergs + rn_LoW_ratio = 1.5 ! Initial ratio L/W for newly calved icebergs + ln_operator_splitting = .true. ! Use first order operator splitting for thermodynamics + rn_bits_erosion_fraction = 0. ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0. ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0. ! CFL speed limit for a berg + + cn_dir = './' ! root directory for the calving 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_icb = 'calving' , -1. ,'calvingmask', .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) +!----------------------------------------------------------------------- + ! ! free slip ! partial slip ! no slip ! strong slip + rn_shlat = -9999. ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. + ln_shlat2d = .false. + cn_shlat2d_file = "empty" + cn_shlat2d_var = "empty" +/ +!----------------------------------------------------------------------- +&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 +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .false. ! Activate tides + ln_tide_pot = .false. ! use tidal potential forcing + ln_scal_load = .false. ! Use scalar approximation for + rn_scal_load = 0.094 ! load potential + ln_read_load = .false. ! Or read load potential from file + cn_tide_load = 'tide_LOAD_grid_T.nc' ! filename for load potential + ! + ln_tide_ramp = .false. ! Use linear ramp for tides at startup + rdttideramp = 0. ! ramp duration in days + clname(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .false. ! Use unstructured open boundaries + nb_bdy = 0 ! number of open boundary sets + ln_coords_file = .true. ! =T : read bdy coordinates from file + cn_coords_file = 'coordinates.bdy.nc' ! bdy coordinates files + ln_mask_file = .false. ! =T : read mask from file + cn_mask_file = '' ! name of mask file (if ln_mask_file=.TRUE.) + cn_dyn2d = 'none' ! + nn_dyn2d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! ! = 2, use tidal harmonic forcing data from files + ! ! = 3, use external data AND tidal harmonic forcing + cn_dyn3d = 'none' ! + nn_dyn3d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_tra = 'none' ! + nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_ice = 'none' ! + nn_ice_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! + ln_tra_dmp =.false. ! open boudaries conditions for tracers + ln_dyn3d_dmp =.false. ! open boundary condition for baroclinic velocities + rn_time_dmp = 1. ! Damping time scale in days + rn_time_dmp_out = 1. ! Outflow damping time scale + nn_rimwidth = 1 ! width of the relaxation zone + ln_vol = .false. ! total volume correction (see nn_volctl parameter) + nn_volctl = 1 ! = 0, the total water flux across open boundaries is zero +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data (see nam_bdy) +!----------------------------------------------------------------------- + ln_zinterp = .false. ! T if a vertical interpolation is required. Variables gdep[tuv] and e3[tuv] must exist in the file + ! ! automatically defined to T if the number of vertical levels in bdy dta /= jpk + ln_full_vel = .false. ! T if [uv]3d are "full" velocities and not only its baroclinic components + ! ! in this case, baroclinic and barotropic velocities will be recomputed -> [uv]2d not needed + ! + cn_dir = 'bdydta/' ! root directory for the BDY 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 ! + bn_ssh = 'amm12_bdyT_u2d' , 24. , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24. , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24. , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24. , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24. , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24. , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24. , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' , 24. , 'siconc' , .true. , .false., 'daily' , '' , '' , '' + bn_h_i = 'amm12_bdyT_ice' , 24. , 'sithic' , .true. , .false., 'daily' , '' , '' , '' + bn_h_s = 'amm12_bdyT_ice' , 24. , 'snthic' , .true. , .false., 'daily' , '' , '' , '' + bn_t_i = 'NOT USED' , 24. , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24. , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24. , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24. , 'sisalt' , .true. , .false., 'daily' , '' , '' , '' + ! melt ponds (be careful, bn_aip is the pond concentration (not fraction), so it differs from rn_iceapnd) + bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! -- salinity -- + rn_ice_age = 30. ! -- age -- + rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i -- + rn_ice_hpnd = 0.05 ! -- pond depth -- + rn_ice_hlid = 0.0 ! -- pond lid depth -- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries (default: OFF) +!----------------------------------------------------------------------- + filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. ! + ln_bdytide_conj = .false. ! +/ + +!!====================================================================== +!! *** 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_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot + ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) + ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ! + ln_drgimp = .true. ! implicit top/bottom friction flag + ln_drgice_imp = .false. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 1 constant flux + ! ! = 2 read variable flux [mW/m2] + rn_geoflx_cst = 86.4e-3 ! Constant value of geothermal heat 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 = .false. ! 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_teos10 = .true. ! = Use TEOS-10 + ln_eos80 = .false. ! = Use EOS80 + ln_seos = .false. ! = Use S-EOS (simplified Eq.) + ! + ! ! S-EOS coefficients (ln_seos=T): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 1.6550e-1 ! thermal expension coefficient + rn_b0 = 7.6554e-1 ! saline expension coefficient + rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 7.4914e-4 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 1.4970e-4 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.1090e-5 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 2.4341e-3 ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_OFF = .false. ! No tracer advection + ln_traadv_cen = .false. ! 2nd order centered scheme + nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_traadv_fct = .false. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + ln_traadv_mus = .false. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths + ln_traadv_ubs = .false. ! UBS scheme + nn_ubs_v = 2 ! =2 , vertical 2nd order FCT / COMPACT 4th order + ln_traadv_qck = .false. ! QUICKEST scheme +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .false. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator + ! + ! ! Direction of action: + ln_traldf_lev = .false. ! iso-level + ln_traldf_hor = .false. ! horizontal (geopotential) + ln_traldf_iso = .false. ! iso-neutral (standard operator) + ln_traldf_triad = .false. ! iso-neutral (triad operator) + ! + ! ! iso-neutral options: + ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators) + rn_slpmax = 0.01 ! slope limit (both operators) + ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only) + rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only) + ln_botmix_triad = .false. ! lateral mixing on bottom (triad only) + ! + ! ! Coefficients: + nn_aht_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing) + ! ! time invariant coefficients: aht0 = 1/2 Ud*Ld (lap case) + ! ! or = 1/12 Ud*Ld^3 (blp case) + rn_Ud = 0.01 ! 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 = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation + rn_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) + nn_mle = 1 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + rn_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) + nn_mld_uv = 0 ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + nn_conv = 0 ! =1 no MLE in case of convection ; =0 always MLE + rn_rho_c_mle = 0.01 ! delta rho criterion used to calculate MLD for FK +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_induced_velocity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.02 ! 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 =.false. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .false. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column + ! ! =1 no damping in the mixing layer (kz criteria) + ! ! =2 no damping in the mixed layer (rho crieria) + cn_resto = 'resto.nc' ! Name of file containing restoration coeff. field (use dmp_tools to create this) +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! z-star vertical coordinate + ln_vvl_ztilde = .false. ! z-tilde vertical coordinate: only high frequency variations + ln_vvl_layer = .false. ! full layer vertical coordinate + ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar + ln_vvl_zstar_at_eqtor = .false. ! ztilde near the equator + rn_ahe3 = 0.0 ! thickness diffusion coefficient + rn_rst_e3t = 30.0 ! ztilde to zstar restoration timescale [days] + rn_lf_cutoff = 5.0 ! cutoff frequency for low-pass filter [days] + rn_zdef_max = 0.9 ! maximum fractional e3t deformation + ln_vvl_dbg = .true. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .false. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .false. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! energy conserving scheme + ln_dynvor_ens = .false. ! enstrophy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_enT = .false. ! energy conserving scheme (T-point) + ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) + ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE + ! ! (f-point vorticity schemes only) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .false. ! z-coordinate - full steps + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .false. ! s-coordinate (standard jacobian formulation) + ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf + ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) + ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. ! explicit free surface + ln_dynspg_ts = .false. ! split-explicit free surface + ln_bt_fw = .true. ! Forward integration of barotropic Eqs. + ln_bt_av = .true. ! Time filtering of barotropic variables + nn_bt_flt = 1 ! Time filter choice = 0 None + ! ! = 1 Boxcar over nn_baro sub-steps + ! ! = 2 Boxcar over 2*nn_baro " " + ln_bt_auto = .true. ! Number of sub-step defined from: + rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds + rn_bt_alpha = 0. ! Temporal diffusion parameter (if ln_bt_av=F) +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) + ln_dynldf_lap = .false. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coefficient : + ! ! =-30 read in eddy_viscosity_3D.nc file + ! ! =-20 read in eddy_viscosity_2D.nc file + ! ! = 0 constant + ! ! = 10 F(k)=c1d + ! ! = 20 F(i,j)=F(grid spacing)=c2d + ! ! = 30 F(i,j,k)=c2d*c1d + ! ! = 31 F(i,j,k)=F(grid spacing and local velocity) + ! ! = 32 F(i,j,k)=F(local gridscale and deformation rate) + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.1 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) + ! ! Smagorinsky settings (nn_ahm_ijk_t= 32) : + rn_csmc = 3.5 ! Smagorinsky constant of proportionality + rn_minfac = 1.0 ! multiplier of theorectical lower limit + rn_maxfac = 1.0 ! multiplier of theorectical upper limit + ! ! iso-neutral laplacian operator (ln_dynldf_iso=T) : + rn_ahm_b = 0.0 ! background eddy viscosity [m2/s] +/ +!----------------------------------------------------------------------- +&namdta_dyn ! offline ocean input files (OFF_SRC only) +!----------------------------------------------------------------------- + ln_dynrnf = .false. ! runoffs option enabled (T) or not (F) + ln_dynrnf_depth = .false. ! runoffs is spread in vertical (T) or not (F) +! fwbcorr = 3.786e-06 ! annual global mean of empmr for ssh correction + + cn_dir = './' ! root directory for the ocean 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 = 'dyna_grid_T' , 120. , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120. , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120. , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120. , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120. , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120. , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120. , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120. , 'sobblcoy' , .true. , .true. , 'yearly' , '' , '' , '' +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! adaptive-implicit vertical advection + ln_zad_Aimp = .false. ! Courant number dependent scheme (Shchepetkin 2015) + ! + ! ! type of vertical closure (required) + ln_zdfcst = .false. ! constant mixing + ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) + ln_zdftke = .false. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfgls = .false. ! Generic Length Scale closure (T => fill namzdf_gls) + ln_zdfosm = .false. ! OSMOSIS BL closure (T => fill namzdf_osm) + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + nn_evdm = 0 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! mixing coefficient [m2/s] + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + nn_npc = 1 ! frequency of application of npc + nn_npcp = 365 ! npc control print frequency + ! + ln_zdfddm = .false. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ! + ! ! gravity wave-driven vertical mixing + ln_zdfiwm = .false. ! internal wave-induced mixing (T => fill namzdf_iwm) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 100.e-4 ! maximum value of the vertical viscosity + rn_alp = 5. ! coefficient of the parameterization + nn_ric = 2 ! coefficient of the parameterization + ln_mldw = .false. ! enhanced mixing in the Ekman layer + rn_ekmfc = 0.7 ! Factor in the Ekman depth Equation + rn_mldmin = 1.0 ! minimum allowable mixed-layer depth estimate (m) + rn_mldmax = 1000.0 ! maximum allowable mixed-layer depth estimate (m) + rn_wtmix = 10.0 ! vertical eddy viscosity coeff [m2/s] in the mixed-layer + rn_wvmix = 10.0 ! vertical eddy diffusion coeff [m2/s] in the mixed-layer +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + rn_ediff = 0.1 ! coef. for vertical eddy coef. (avt=rn_ediff*mxl*sqrt(e) ) + rn_ediss = 0.7 ! coef. of the Kolmogoroff dissipation + rn_ebb = 67.83 ! coef. of the surface input of tke (=67.83 suggested when ln_mxl0=T) + rn_emin = 1.e-6 ! minimum value of tke [m2/s2] + rn_emin0 = 1.e-4 ! surface minimum value of tke [m2/s2] + rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it) + nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm) + 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 + ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) + nn_mxlice = 2 ! type of scaling under sea-ice + ! = 0 no scaling under sea-ice + ! = 1 scaling with constant sea-ice thickness + ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) + ! = 3 scaling with maximum sea-ice thickness + rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) + rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value + ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002) + rn_lc = 0.15 ! coef. associated to Langmuir cells + 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) + rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) + nn_htau = 1 ! type of exponential decrease of tke penetration below the ML + ! = 0 constant 10 m length scale + ! = 1 0.5m at the equator to 30m poleward of 40 degrees + nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice + ! ! = 0 no impact of ice cover on langmuir & surface wave breaking + ! ! = 1 weigthed by 1-TANH(10*fr_i) + ! ! = 2 weighted by 1-fr_i + ! ! = 3 weighted by 1-MIN(1,4*fr_i) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1.e-7 ! minimum value of e [m2/s2] + rn_epsmin = 1.e-12 ! minimum value of eps [m2/s3] + ln_length_lim = .true. ! limit on the dissipation rate under stable stratification (Galperin et al., 1988) + rn_clim_galp = 0.267 ! galperin limit + ln_sigpsi = .true. ! Activate or not Burchard 2001 mods on psi schmidt number in the wb case + rn_crban = 100. ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000. ! Charnock constant for wb induced roughness length + rn_hsro = 0.02 ! Minimum surface roughness + rn_hsri = 0.03 ! Ice-ocean roughness + rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1) + nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) + ! ! = 3 requires ln_wave=T + nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice + ! ! = 0 no impact of ice cover + ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i) + ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i + ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i) + nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum) + nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum) + nn_stab_func = 2 ! stability function (0=Galp, 1= KC94, 2=CanutoA, 3=CanutoB) + nn_clos = 1 ! predefined closure type (0=MY82, 1=k-eps, 2=k-w, 3=Gen) +/ +!----------------------------------------------------------------------- +&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) +!----------------------------------------------------------------------- + ln_use_osm_la = .false. ! Use namelist rn_osm_la + rn_osm_la = 0.3 ! Turbulent Langmuir number + rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) + nn_ave = 0 ! choice of horizontal averaging on avt, avmu, avmv + ln_dia_osm = .true. ! output OSMOSIS-OBL variables + rn_osm_hbl0 = 10. ! initial hbl value + ln_kpprimix = .true. ! Use KPP-style Ri# mixing below BL + rn_riinfty = 0.7 ! Highest local Ri_g permitting shear instability + rn_difri = 0.005 ! max Ri# diffusivity at Ri_g = 0 (m^2/s) + ln_convmix = .true. ! Use convective instability mixing below BL + rn_difconv = 1. ! diffusivity when unstable below BL (m2/s) + nn_osm_wave = 0 ! Method used to calculate Stokes drift + ! ! = 2: Use ECMWF wave fields + ! ! = 1: Pierson Moskowitz wave spectrum + ! ! = 0: Constant La# = 0.3 +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) + ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency + ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) +/ + +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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_diaharm Harmonic analysis of tidal constituents (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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtrd ! trend diagnostics (default: OFF) +!----------------------------------------------------------------------- + ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE + ln_dyn_trd = .false. ! (T) 3D momentum trend output + ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet) + ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet) + ln_KE_trd = .false. ! (T) 3D Kinetic Energy trends + ln_PE_trd = .false. ! (T) 3D Potential Energy trends + ln_tra_trd = .false. ! (T) 3D tracer trend output + ln_tra_mxl = .false. ! (T) 2D tracer trends averaged over the mixed layer (not coded yet) + nn_trd = 365 ! print frequency (ln_glo_trd=T) (unit=time step) +/ +!!gm nn_ctls = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) +!!gm cn_trdrst_in = "restart_mld" ! suffix of ocean restart name (input) +!!gm cn_trdrst_out = "restart_mld" ! suffix of ocean restart name (output) +!!gm ln_trdmld_restart = .false. ! restart for ML diagnostics +!!gm ln_trdmld_instant = .false. ! flag to diagnose trends of instantantaneous or mean ML T/S +!!gm +!----------------------------------------------------------------------- +&namptr ! Poleward Transport Diagnostic (default: OFF) +!----------------------------------------------------------------------- + ln_diaptr = .false. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .false. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .false. ! output the heat and salt budgets (T) or not (F) +/ +!----------------------------------------------------------------------- +&namdiu ! Cool skin and warm layer models (default: OFF) +!----------------------------------------------------------------------- + ln_diurnal = .false. ! + ln_diurnal_only = .false. ! +/ +!----------------------------------------------------------------------- +&namflo ! float parameters (default: OFF) +!----------------------------------------------------------------------- + ln_floats = .false. ! activate floats or not + jpnfl = 1 ! total number of floats during the run + jpnnewflo = 0 ! number of floats for the restart + ln_rstflo = .false. ! float restart (T) or not (F) + nn_writefl = 75 ! frequency of writing in float output file + nn_stockfl = 5475 ! frequency of creation of the float restart file + ln_argo = .false. ! Argo type floats (stay at the surface each 10 days) + ln_flork4 = .false. ! trajectories computed with a 4th order Runge-Kutta (T) + ! ! or computed with Blanke' scheme (F) + ln_ariane = .true. ! Input with Ariane tool convention(T) + ln_flo_ascii= .true. ! Output with Ariane tool netcdf convention(F) or ascii file (T) +/ +!----------------------------------------------------------------------- +&nam_diaharm ! Harmonic analysis of tidal constituents (default: OFF) +!----------------------------------------------------------------------- + ln_diaharm = .false. ! Choose tidal harmonic output or not + nit000_han = 1 ! First time step used for harmonic analysis + nitend_han = 75 ! Last time step used for harmonic analysis + nstep_han = 15 ! Time step frequency for harmonic analysis + tname(1) = 'M2' ! Name of tidal constituents + tname(2) = 'K1' ! --- +/ +!----------------------------------------------------------------------- +&nam_diadct ! transports through some sections (default: OFF) +!----------------------------------------------------------------------- + ln_diadct = .false. ! Calculate transport thru sections or not + nn_dct = 15 ! time step frequency for transports computing + nn_dctwri = 15 ! time step frequency for transports writing + nn_secdebug = 112 ! 0 : no section to debug + ! ! -1 : debug all section + ! ! 0 < n : debug section number n +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default: OFF) +!----------------------------------------------------------------------- + ln_dia25h = .false. ! Choose 25h mean output or not +/ +!----------------------------------------------------------------------- +&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") +!----------------------------------------------------------------------- + nn_nchunks_i = 4 ! number of chunks in i-dimension + nn_nchunks_j = 4 ! number of chunks in j-dimension + nn_nchunks_k = 31 ! number of chunks in k-dimension + ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which + ! ! is optimal for postprocessing which works exclusively with horizontal slabs + ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression + ! ! (F) ignore chunking information and produce netcdf3-compatible files +/ + +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!----------------------------------------------------------------------- +&namobs ! observation usage switch (default: OFF) +!----------------------------------------------------------------------- + ln_diaobs = .false. ! Logical switch for the observation operator + ! + ln_t3d = .false. ! Logical switch for T profile observations + ln_s3d = .false. ! Logical switch for S profile observations + ln_sla = .false. ! Logical switch for SLA observations + ln_sst = .false. ! Logical switch for SST observations + ln_sss = .false. ! Logical swithc for SSS observations + ln_sic = .false. ! Logical switch for Sea Ice observations + ln_vel3d = .false. ! Logical switch for velocity observations + ln_altbias = .false. ! Logical switch for altimeter bias correction + ln_sstbias = .false. ! Logical switch for SST bias correction + ln_nea = .false. ! Logical switch for rejection of observations near land + ln_grid_global = .true. ! Logical switch for global distribution of observations + ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table + ln_ignmis = .true. ! Logical switch for ignoring missing files + ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there + ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs + ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. + ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres + ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres + ln_sss_fp_indegs = .true. ! Logical for SSS: T=> averaging footprint is in degrees, F=> in metres + ln_sic_fp_indegs = .true. ! Logical for SIC: T=> averaging footprint is in degrees, F=> in metres +! All of the *files* variables below are arrays. Use namelist_cfg to add more files + cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names + cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names + cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names + cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names + cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names + cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names + cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name + cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file name + cn_gridsearchfile ='gridsearch.nc' ! Grid search file name + rn_gridsearchres = 0.5 ! Grid search resolution + rn_mdtcorr = 1.61 ! MDT correction + rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction + rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) + nn_1dint = 0 ! Type of vertical interpolation method + nn_2dint = 0 ! Default horizontal interpolation method + nn_2dint_sla = 0 ! Horizontal interpolation method for SLA + nn_2dint_sst = 0 ! Horizontal interpolation method for SST + nn_2dint_sss = 0 ! Horizontal interpolation method for SSS + nn_2dint_sic = 0 ! Horizontal interpolation method for SIC + nn_msshc = 0 ! MSSH correction scheme + nn_profdavtypes = -1 ! Profile daily average types - array +/ +!----------------------------------------------------------------------- +&nam_asminc ! assimilation increments ('key_asminc') +!----------------------------------------------------------------------- + ln_bkgwri = .false. ! Logical switch for writing out background state + ln_trainc = .false. ! Logical switch for applying tracer increments + ln_dyninc = .false. ! Logical switch for applying velocity increments + ln_sshinc = .false. ! Logical switch for applying SSH increments + ln_asmdin = .false. ! Logical switch for Direct Initialization (DI) + ln_asmiau = .false. ! Logical switch for Incremental Analysis Updating (IAU) + nitbkg = 0 ! Timestep of background in [0,nitend-nit000-1] + nitdin = 0 ! Timestep of background for DI in [0,nitend-nit000-1] + nitiaustr = 1 ! Timestep of start of IAU interval in [0,nitend-nit000-1] + nitiaufin = 15 ! Timestep of end of IAU interval in [0,nitend-nit000-1] + niaufn = 0 ! Type of IAU weighting function + ln_salfix = .false. ! Logical switch for ensuring that the sa > salfixmin + salfixmin = -9999 ! Minimum salinity after applying the increments + nn_divdmp = 0 ! Number of iterations of divergence damping operator +/ + +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_listonly = .false. ! do nothing else than listing the best domain decompositions (with land domains suppression) + ! ! if T: the largest number of cores tested is defined by max(mppsize, jpni*jpnj) + ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold + jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T + sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following + sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings. + sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure + sn_cfctl%l_oceout = .FALSE. ! that all areas report. + sn_cfctl%l_layout = .FALSE. ! + sn_cfctl%l_mppout = .FALSE. ! + sn_cfctl%l_mpptop = .FALSE. ! + sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0] + sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000] + sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1] + sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info + nn_print = 0 ! level of print (0 no extra print) + nn_ictls = 0 ! start i indice of control sum (use to compare mono versus + nn_ictle = 0 ! end i indice of control sum multi processor runs + nn_jctls = 0 ! start j indice of control over a subdomain) + nn_jctle = 0 ! end j indice of control + nn_isplt = 1 ! number of processors in i-direction + nn_jsplt = 1 ! number of processors in j-direction + ln_timing = .false. ! timing by routine write out in timing.output file + ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- + ln_sto_eos = .false. ! stochastic equation of state + nn_sto_eos = 1 ! number of independent random walks + rn_eos_stdxy = 1.4 ! random walk horz. standard deviation (in grid points) + rn_eos_stdz = 0.7 ! random walk vert. standard deviation (in grid points) + rn_eos_tcor = 1440. ! random walk time correlation (in timesteps) + nn_eos_ord = 1 ! order of autoregressive processes + nn_eos_flt = 0 ! passes of Laplacian filter + rn_eos_lim = 2.0 ! limitation factor (default = 3.0) + ln_rststo = .false. ! start from mean parameter (F) or from restart file (T) + ln_rstseed = .true. ! read seed of RNG from restart file + cn_storst_in = "restart_sto" ! suffix of stochastic parameter restart file (input) + cn_storst_out = "restart_sto" ! suffix of stochastic parameter restart file (output) +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/runscript.slurm b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/runscript.slurm new file mode 100644 index 0000000..4b4c8b9 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXPREF/runscript.slurm @@ -0,0 +1,46 @@ +#!/bin/bash +#SBATCH --job-name=amm7surge +#SBATCH --time=00:05:00 +#SBATCH --nodes=2 +#SBATCH --ntasks-per-core=1 +#SBATCH --account=n01-class +#SBATCH --partition=standard +#SBATCH --qos=standard +#SBATCH -o %A_%a.out +#SBATCH -e %A_%a.err + +start=`date +%s` + +# Created by: mkslurm_hetjob -S 4 -s 16 -m 2 -C 96 -g 2 -N 128 -t 00:10:00 -a n01 -j nemo_test -v False +#module swap PrgEnv-cray/8.0.0 PrgEnv-gnu/8.1.0 +#module swap craype-network-ofi craype-network-ucx +#module swap cray-mpich cray-mpich-ucx +#module load cray-hdf5-parallel/1.12.0.7 +#module load cray-netcdf-hdf5parallel/4.7.4.7 +#module load libfabric +#module list +export OMP_NUM_THREADS=1 + +cat > myscript_wrapper.sh << EOFB +#!/bin/ksh +# +set -A map ./xios_server.exe ./nemo +exec_map=( 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) +# +exec \${map[\${exec_map[\$SLURM_PROCID]}]} +## +EOFB +chmod u+x ./myscript_wrapper.sh + +srun --mem-bind=local \ +--ntasks=100 --ntasks-per-node=50 --cpu-bind=v,mask_cpu:0x1,0x10000,0x100000000,0x400000000,0x1000000000,0x4000000000,0x10000000000,0x40000000000,0x100000000000,0x400000000000,0x1000000000000,0x4000000000000,0x10000000000000,0x40000000000000,0x100000000000000,0x400000000000000,0x1000000000000000,0x4000000000000000,0x10000000000000000,0x40000000000000000,0x100000000000000000,0x400000000000000000,0x1000000000000000000,0x4000000000000000000,0x10000000000000000000,0x40000000000000000000,0x100000000000000000000,0x400000000000000000000,0x1000000000000000000000,0x4000000000000000000000,0x10000000000000000000000,0x40000000000000000000000,0x100000000000000000000000,0x400000000000000000000000,0x1000000000000000000000000,0x4000000000000000000000000,0x10000000000000000000000000,0x40000000000000000000000000,0x100000000000000000000000000,0x400000000000000000000000000,0x1000000000000000000000000000,0x4000000000000000000000000000,0x10000000000000000000000000000,0x40000000000000000000000000000,0x100000000000000000000000000000,0x400000000000000000000000000000,0x1000000000000000000000000000000,0x4000000000000000000000000000000,0x10000000000000000000000000000000,0x40000000000000000000000000000000 ./myscript_wrapper.sh + + +end=`date +%s` +runtime=$((end-start)) +hours=$((runtime / 3600)) +minutes=$(( (runtime % 3600) / 60 )) +seconds=$(( (runtime % 3600) % 60 )) +echo "Runtime: $hours:$minutes:$seconds (hh:mm:ss)" +wait +exit diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/RESTARTS/README.txt b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/RESTARTS/README.txt new file mode 100644 index 0000000..18b4d3f --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/RESTARTS/README.txt @@ -0,0 +1 @@ +directory for storing restart files diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/bdydta b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/bdydta new file mode 120000 index 0000000..c6bb8c1 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/bdydta @@ -0,0 +1 @@ +/work/n01/n01/shared/CO_AMM7/TIDE/FES \ No newline at end of file diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/context_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/context_nemo.xml new file mode 100644 index 0000000..a12b8bd --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/context_nemo.xml @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/domain_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/domain_def_nemo.xml new file mode 100644 index 0000000..0931e2b --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/domain_def_nemo.xml @@ -0,0 +1,198 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/field_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/field_def_nemo-oce.xml new file mode 100644 index 0000000..62b0bb6 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/field_def_nemo-oce.xml @@ -0,0 +1,1129 @@ + + + + + + + + + + + + + + + + + + + + + + + toce_pot * e3t + + soce_pra * e3t + + + toce_con * e3t + + soce_abs * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + sst_pot * sst_pot + + + + + + + + + + + + sss_pra * sss_pra + + + + + + + sst_con * sst_con + + + + + + + + + + + + sss_abs * sss_abs + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + uoce * uoce * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + voce * voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + ut * e3u + + us * e3u + + urhop * e3u + + vt * e3v + + vs * e3v + + vrhop * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + @voce_e3v + + this * e1v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sophtvtr - sophtove + sophtvtr - sopstove + + + + + + + + + + + + + + + + + + + ttrd_atf * e3t + strd_atf * e3t + + ttrd_atf_e3t * 1026.0 * 3991.86795711963 + strd_atf_e3t * 1026.0 * 0.001 + + + + + + + + + + + sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) + sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) + + + + + + + + + + + + + ttrd_ldf + ttrd_zdf - ttrd_zdfp + strd_ldf + strd_zdf - strd_zdfp + + + + + + + + + + + + + + + + + ttrd_xad * e3t + strd_xad * e3t + ttrd_yad * e3t + strd_yad * e3t + ttrd_zad * e3t + strd_zad * e3t + ttrd_ad * e3t + strd_ad * e3t + ttrd_totad * e3t + strd_totad * e3t + ttrd_ldf * e3t + strd_ldf * e3t + ttrd_zdf * e3t + strd_zdf * e3t + ttrd_evd * e3t + strd_evd * e3t + + + ttrd_iso * e3t + strd_iso * e3t + ttrd_zdfp * e3t + strd_zdfp * e3t + + + ttrd_dmp * e3t + strd_dmp * e3t + ttrd_bbl * e3t + strd_bbl * e3t + ttrd_npc * e3t + strd_npc * e3t + ttrd_qns * e3ts + strd_cdt * e3ts + ttrd_qsr * e3t + ttrd_bbc * e3t + + + ttrd_totad_e3t * 1026.0 * 3991.86795711963 + strd_totad_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + ttrd_iso_e3t * 1026.0 * 3991.86795711963 + strd_iso_e3t * 1026.0 * 0.001 + ttrd_zdfp_e3t * 1026.0 * 3991.86795711963 + strd_zdfp_e3t * 1026.0 * 0.001 + ttrd_qns_e3t * 1026.0 * 3991.86795711963 + ttrd_qsr_e3t * 1026.0 * 3991.86795711963 + ttrd_bbl_e3t * 1026.0 * 3991.86795711963 + strd_bbl_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + + + + + + + + + ttrd_tot * e3t + strd_tot * e3t + + ttrd_tot_e3t * 1026.0 * 3991.86795711963 + strd_tot_e3t * 1026.0 * 0.001 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/field_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/field_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/EXP_tideonly/file_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/file_def_nemo-oce.xml similarity index 67% rename from EXP_tideonly/file_def_nemo-opa.xml rename to NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/file_def_nemo-oce.xml index c66e9d3..beb06e6 100644 --- a/EXP_tideonly/file_def_nemo-opa.xml +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/file_def_nemo-oce.xml @@ -1,5 +1,4 @@ - - - + - - - - ---> - - + + + + + + + - - + + - + + - + + @@ -49,7 +48,4 @@ - - - diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/file_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/file_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/grid_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/grid_def_nemo.xml new file mode 100644 index 0000000..b370feb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/grid_def_nemo.xml @@ -0,0 +1,180 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/iodef.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/iodef.xml new file mode 100644 index 0000000..8bfff14 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/iodef.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + -1 + true + false + oceanx + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/myscript_wrapper.sh b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/myscript_wrapper.sh new file mode 100755 index 0000000..87e905e --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/myscript_wrapper.sh @@ -0,0 +1,7 @@ +#!/bin/ksh +# +set -A map ./xios_server.exe ./nemo +exec_map=( 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) +# +exec ${map[${exec_map[$SLURM_PROCID]}]} +## diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/namelist_cfg b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/namelist_cfg new file mode 100644 index 0000000..6d8be26 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/namelist_cfg @@ -0,0 +1,366 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! AMM12 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = "AMMSRG_met" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 7008 ! 52560 ! last time step (std 1 day = 192) + nn_date0 = 20170101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_leapy = 1 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "./RESTARTS" ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "./RESTARTS" ! directory in which to write output ocean restarts + nn_stock = 70080 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 192 ! 52560 ! frequency of write in the output file (modulo referenced to nit000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 450. ! time step for the dynamics (and tracer if nn_acc=0) + ln_2d = .true. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: user defined GYRE) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + cn_domcfg = "amm7_surge_domain_cfg" ! domain configuration filename +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells +/ +!!====================================================================== +!! *** 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 (surface module) (default: NO selection) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of SBC module call + ln_usr = .true. + ln_flx = .false. ! flux formulation (T => fill namsbc_flx) + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .true. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) +/ +!----------------------------------------------------------------------- +&namsbc_usr ! namsbc_surge surge model fluxes +!----------------------------------------------------------------------- + ln_use_sbc = .true. ! (T) to turn on surge fluxes (wind and pressure only) + ! (F) for no fluxes (ie tide only case) + +! +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! + sn_wndi = 'ERA5_U10' , 1 ,'U10', .true. , .false. , 'yearly' ,'weights_era5_bicubic.nc' , 'Uwnd', 'ERA5_LSM' + sn_wndj = 'ERA5_V10' , 1 ,'V10', .true. , .false. , 'yearly' ,'weights_era5_bicubic.nc' , 'Vwnd' , 'ERA5_LSM' + cn_dir = './fluxes/' ! root directory for the location of the bulk files + rn_vfac = 1. ! multiplicative factor for ocean/ice velocity + ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) + rn_charn_const = 0.0275 +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101200. ! reference atmospheric pressure [N/m2] + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .true. ! inverse barometer added to OBC ssh data + + cn_dir = './fluxes/' ! root directory for the Patm 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_apr = 'ERA5_MSL' , 1 , 'MSL' , .true. , .false., 'yearly' , 'weights_era5_bicubic.nc', 'Uwnd' , 'ERA5_LSM' +/ +!!====================================================================== +!! *** 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 = 0 ! free slip +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .true. + clname(1) = 'M2' ! name of constituent + clname(2) = 'S2' + clname(3) = 'K2' +! clname(1) ='2N2' +! clname(2)='EPS2' +! clname(3)='J1' +! clname(4)='K1' +! clname(5)='K2' +! clname(6)='L2' +! clname(7)='LA2' +! clname(8)='M2' +! clname(9)='M3' +! clname(10)='M4' +! clname(11)='M6' +! clname(12)='M8' +! clname(13)='MF' +! clname(14)='MKS2' +! clname(15)='MM' +! clname(16)='MN4' +! clname(17)='MS4' +! clname(18)='MSF' +! clname(19)='MSQM' +! clname(20)='MTM' +! clname(21)='MU2' +! clname(22)='N2' +! clname(23)='N4' +! clname(24)='NU2' +! clname(25)='O1' +! clname(26)='P1' +! clname(27)='Q1' +! clname(28)='R2' +! clname(29)='S1' +! clname(30)='S2' +! clname(31)='S4' +! clname(32)='SA' +! clname(33)='SSA' +! clname(34)='T2' +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .true. + nb_bdy = 1 ! number of open boundary sets + cn_dyn2d = 'flather' ! + nn_dyn2d_dta = 2 ! = 0, bdy data are equal to the initial state + ! = 1, bdy data are read in 'bdydata .nc' files + ! = 2, use tidal harmonic forcing data from files + ! = 3, use external data AND tidal harmonic forcing +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries +!----------------------------------------------------------------------- + filtide = 'bdydta/AMM7_surge_bdytide_rotT_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!! !! +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T) +!! namdrg_bot bottom friction (ln_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_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction +!----------------------------------------------------------------------- + rn_Cd0 = 2.4e-3 ! CO'N used 1e-5 with ln_boost field (4Jan24) ! drag coefficient [-] + rn_ke0 = 0.0e0 ! background kinetic energy [m2/s2] (non-linear cases) + ln_boost = .false., + rn_boost = 1., +/ +!!====================================================================== +!! 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_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) +/ +!----------------------------------------------------------------------- +&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 scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .true. ! Number of sub-step defined from: +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_blp = .true. ! bilaplacian operator + ln_dynldf_lap = .false. ! bilaplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = 0 ! =0 constant = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.012 ! lateral viscous velocity [m/s] + rn_Lv = 1.e+4 ! lateral viscous length [m] +/ +!!====================================================================== +!! 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 (default: NO selection) +!----------------------------------------------------------------------- + rn_avm0 = 0.1e-6 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.1e-6 ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_charn = 100000. ! Charnock constant for wb induced roughness length + nn_z0_met = 1 ! Method for surface roughness computation (0/1/2) +/ +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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 ("key_float") +!! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") +!! namdct transports through some sections ("key_diadct") +!! nam_diatmb Top Middle Bottom Output (default: OFF) +!! nam_dia25h 25h Mean Output (default: OFF) +!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_diatmb ! Top Middle Bottom Output (default F) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default F) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .false. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/namelist_ref b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/namelist_ref new file mode 100644 index 0000000..f962f37 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/namelist_ref @@ -0,0 +1,1386 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : Reference namelist_ref !! +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : 1 - Domain & run manager (namrun, namcfg, namdom, namtsd, namcrs, namc1d, namc1d_uvd) +!! namelists 2 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_cpl, +!! namsbc_sas, namtra_qsr, namsbc_rnf, +!! namsbc_isf, namsbc_iscpl, namsbc_apr, +!! namsbc_ssr, namsbc_wave, namberg) +!! 3 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide) +!! 4 - top/bot boundary (namdrg, namdrg_top, namdrg_bot, nambbc, nambbl) +!! 5 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_eiv, namtra_dmp) +!! 6 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) +!! 7 - Vertical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_gls, namzdf_iwm) +!! 8 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb) +!! 9 - Obs & Assim (namobs, nam_asminc) +!! 10 - miscellaneous (nammpp, namctl, namsto) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!!====================================================================== +!! *** 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! Assimilation cycle index + cn_exp = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5840) + nn_date0 = 010101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_time0 = 0 ! initial time of day in hhmm + nn_leapy = 0 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T + nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T + ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist + ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart + ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "." ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "." ! directory in which to write output ocean restarts + ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model + nn_istate = 0 ! output the initial state (1) or not (0) + ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) + nn_stock = 0 ! used only if ln_rst_list = F: output restart freqeuncy (modulo referenced to 1) + ! ! = 0 force to write restart files only at the end of the run + ! ! = -1 do not do any restart + nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written + nn_write = 0 ! used only if key_iomput is not defined: output frequency (modulo referenced to nn_it000) + ! ! = 0 force to write output files only at the end of the run + ! ! = -1 do not do any output file + ln_mskland = .false. ! mask land points in NetCDF outputs + ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + ln_xios_read = .FALSE. ! use XIOS to read restart file (only for a single file restart) + nn_wxios = 0 ! use XIOS to write restart file 0 - no, 1 - single file output, 2 - multiple file output + ln_rst_eos = .TRUE. ! check if the equation of state used to produce the restart is consistent with model +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.00 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 5400. ! time step for the dynamics and tracer + rn_atfp = 0.1 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_2d = .false. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration (F => create/check namusr_def) + cn_domcfg = "domain_cfg" ! domain configuration filename + ! + ln_closea = .false. ! T => keep closed seas (defined by closea_mask field) in the + ! ! domain and apply special treatment of freshwater fluxes. + ! ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. + ! ! If closea_mask field doesn't exist in the domain_cfg file + ! ! then this logical does nothing. + ln_write_cfg = .false. ! (=T) create the domain configuration file + cn_domcfg_out = "domain_cfg_out" ! newly created domain configuration filename + ! + ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present + ! ! in netcdf input files, as the start j-row for reading +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .false. ! ocean initialisation + ln_tsd_dmp = .false. ! 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' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_il = .false. ! T/F activation of iterative limiter + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells + rn_wdld = 2.5 ! Land elevation below which WaD is allowed + nn_wdit = 20 ! Max iterations for WaD limiter + rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes + rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) +/ +!----------------------------------------------------------------------- +&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T) +!----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_binref = 0 ! Bin centering preference: NORTH or EQUAT + ! ! 0, coarse grid is binned with preferential treatment of the north fold + ! ! 1, coarse grid is binned with centering at the equator + ! ! Symmetry with nn_facty being odd-numbered. Asymmetry with even-numbered nn_facty. + ln_msh_crs = .false. ! =T create a mesh & mask file + nn_crs_kz = 0 ! 0, MEAN of volume boxes + ! ! 1, MAX of boxes + ! ! 2, MIN of boxes + ln_crs_wn = .true. ! wn coarsened (T) or computed using horizontal divergence ( F ) +/ +!----------------------------------------------------------------------- +&namc1d ! 1D configuration options ("key_c1d" default: PAPA station) +!----------------------------------------------------------------------- + rn_lat1d = 50 ! Column latitude + rn_lon1d = -145 ! Column longitude + ln_c1d_locpt = .true. ! Localization of 1D config in a grid (T) or independant point (F) +/ +!----------------------------------------------------------------------- +&namc1d_dyndmp ! U & V newtonian damping ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ln_dyndmp = .false. ! add a damping term (T) or not (F) +/ +!----------------------------------------------------------------------- +&namc1d_uvd ! data: U & V currents ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ! ! =T read U-V fields for: + ln_uvd_init = .false. ! ocean initialisation + ln_uvd_dyndmp = .false. ! U-V restoring + + cn_dir = './' ! root directory for the U-V 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_ucur = 'ucurrent' , -1. ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' + sn_vcur = 'vcurrent' , -1. ,'v_current', .false. , .true. , 'monthly' , '' , 'Vme' , '' +/ + +!!====================================================================== +!! *** 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 = 2 ! frequency of SBC module call + ! ! (control sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_usr = .false. ! user defined formulation (T => check usrdef_sbc) + ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + ! ! Type of coupling (Ocean/Ice/Atmosphere) : + ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) + ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) + nn_components = 0 ! configuration of the opa-sas OASIS coupling + ! ! =0 no opa-sas OASIS coupling: default single executable config. + ! ! =1 opa-sas OASIS coupling: multi executable config., OPA component + ! ! =2 opa-sas OASIS coupling: multi executable config., SAS component + ! Sea-ice : + nn_ice = 0 ! =0 no ice boundary condition + ! ! =1 use observed ice-cover ( => fill namsbc_iif ) + ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice") + ! ! except in AGRIF zoom where it has to be specified + ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges) + ! ! =F levitating ice (no pressure, mass and salt exchanges) + ! Misc. options of sbc : + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked + ! ! =1 global mean of e-p-r set to zero at each time step + ! ! =2 annual global mean of e-p-r set to zero + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .false. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave) + nn_sdrift = 0 ! Parameterization for the calculation of 3D-Stokes drift from the surface Stokes drift + ! ! = 0 Breivik 2015 parameterization: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] + ! ! = 1 Phillips: v_z=v_o*[exp(2*k*z)-beta*sqrt(-2*k*pi*z)*erfc(sqrt(-2*k*z))] + ! ! = 2 Phillips as (1) but using the wave frequency from a wave model + ln_tauwoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave) + ln_tauw = .false. ! Activate ocean stress components from wave model + ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) + nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , + ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) +/ +!----------------------------------------------------------------------- +&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the fluxes 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_utau = 'utau' , 24. , 'utau' , .false. , .false., 'yearly' , '' , '' , '' + sn_vtau = 'vtau' , 24. , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' + sn_qtot = 'qtot' , 24. , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' + sn_qsr = 'qsr' , 24. , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' + sn_emp = 'emp' , 24. , 'emp' , .false. , .false., 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .false. ! "NCAR" algorithm (Large and Yeager 2008) + ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) + ln_COARE_3p5 = .false. ! "COARE 3.5" algorithm (Edson et al. 2013) + ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) + ! + rn_zqt = 10. ! Air temperature & humidity reference height (m) + rn_zu = 10. ! Wind vector reference height (m) + ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012) + ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015) + ln_taudif = .false. ! HF tau contribution: use "mean of stress module - module of the mean stress" data + rn_pfac = 1. ! multiplicative factor for precipitation (total & snow) + rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to + ! ! calculate the wind stress (0.=absolute or 1.=relative winds) + + 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_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' + sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' + sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tdif = 'taudif_core' , 24. , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") +!----------------------------------------------------------------------- + nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data + ln_usecplmask = .false. ! 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) + ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1) + !_____________!__________________________!____________!_____________!______________________!________! + ! ! description ! multiple ! vector ! vector ! vector ! + ! ! ! categories ! reference ! orientation ! grids ! +!*** send *** + sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , '' + sn_snd_alb = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick = 'none' , 'no' , '' , '' , '' + sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' + sn_snd_co2 = 'coupled' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick1 = 'ice and snow' , 'no' , '' , '' , '' + sn_snd_mpnd = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_sstfrz = 'coupled' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'no' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'none' , 'no' , '' , '' , '' + sn_rcv_taumod = 'coupled' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , 'U,V' + sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'no' , '' , '' , '' + sn_rcv_rnf = 'coupled' , 'no' , '' , '' , '' + sn_rcv_cal = 'coupled' , 'no' , '' , '' , '' + sn_rcv_co2 = 'coupled' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'none' , 'no' , '' , '' , '' + sn_rcv_mslp = 'none' , 'no' , '' , '' , '' + sn_rcv_phioc = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfx = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfy = 'none' , 'no' , '' , '' , '' + sn_rcv_wper = 'none' , 'no' , '' , '' , '' + sn_rcv_wnum = 'none' , 'no' , '' , '' , '' + sn_rcv_wfreq = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' + sn_rcv_ts_ice = 'none' , 'no' , '' , '' , '' + sn_rcv_isf = 'none' , 'no' , '' , '' , '' + sn_rcv_icb = 'none' , 'no' , '' , '' , '' + sn_rcv_tauwoc = 'none' , 'no' , '' , '' , '' + sn_rcv_tauw = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .true. ! =T Read in file ; =F set all to 0. (see sbcssm) + ln_3d_uve = .false. ! specify whether we are supplying a 3D u,v and e3 field + ln_read_frq = .false. ! specify whether we must read frq or not + + cn_dir = './' ! root directory for the ocean 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_usp = 'sas_grid_U' , 120. , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsp = 'sas_grid_V' , 120. , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tem = 'sas_grid_T' , 120. , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sas_grid_T' , 120. , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_ssh = 'sas_grid_T' , 120. , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' + sn_e3t = 'sas_grid_T' , 120. , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' + sn_frq = 'sas_grid_T' , 120. , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the ice cover 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_ice ='ice_cover_clim.nc' , -12. ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .false. ! RGB light penetration (Red-Green-Blue) + ln_qsr_2bd = .false. ! 2BD light penetration (two bands) + ln_qsr_bio = .false. ! bio-model light penetration + ! ! RGB & 2BD choices: + rn_abs = 0.58 ! RGB & 2BD: fraction absorbed in the very near surface + rn_si0 = 0.35 ! RGB & 2BD: shortess depth of extinction + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) + rn_si1 = 23.0 ! 2BD : longest depth of extinction + + 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_sstr = 0 ! add a retroaction term to the surface heat flux (=1) or not (=0) + rn_dqdt = -40. ! magnitude of the retroaction on temperature [W/m2/K] + nn_sssr = 0 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + 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] + nn_sssr_ice = 1 ! control of sea surface restoring under sea-ice + ! 0 = no restoration under ice : * (1-icefrac) + ! 1 = restoration everywhere + ! >1 = enhanced restoration under ice : 1+(nn_icedmp-1)*icefrac + cn_dir = './' ! root directory for the SST/SSS 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_sst = 'sst_data' , 24. , 'sst' , .false. , .false., 'yearly' , '' , '' , '' + sn_sss = 'sss_data' , -1. , 'sss' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .false. ! 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 + ln_rnf_depth = .false. ! read in depth information for runoff + ln_rnf_tem = .false. ! read in temperature information for runoff + ln_rnf_sal = .false. ! read in salinity information for runoff + ln_rnf_depth_ini = .false. ! compute depth at initialisation from runoff file + rn_rnf_max = 5.735e-4 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150. ! depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) + nn_rnf_depth_file = 0 ! create (=1) a runoff depth file or not (=0) + ln_rnf_icb = .false. ! read in iceberg flux from a file (fill sn_i_rnf if .true.) + + cn_dir = './' ! root directory for the runoff 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_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' , '' , '' , '' + sn_i_rnf = 'NOT_USED' , -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000. ! reference atmospheric pressure [N/m2]/ + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .false. ! inverse barometer added to OBC ssh data + + cn_dir = './' ! root directory for the Patm 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_apr = 'patm' , -1. ,'somslpre' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_isf ! Top boundary layer (ISF) (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + ! ! type of top boundary layer + nn_isf = 1 ! ice shelf melting/freezing + ! 1 = presence of ISF ; 2 = bg03 parametrisation + ! 3 = rnf file for ISF ; 4 = ISF specified freshwater flux + ! options 1 and 4 need ln_isfcav = .true. (domzgr) + ! ! nn_isf = 1 or 2 cases: + rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula + rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) + ! ! 0 => thickness of the tbl = thickness of the first wet cell + ! ! nn_isf = 1 case + nn_isfblk = 1 ! 1 ISOMIP like: 2 equations formulation (Hunter et al., 2006) + ! ! 2 ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) + nn_gammablk = 1 ! 0 = cst Gammat (= gammat/s) + ! ! 1 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) + ! ! 2 = velocity and stability dependent Gamma (Holland et al. 1999) + + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! 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 ! +!* nn_isf = 4 case + sn_fwfisf = 'rnfisf' , -12. ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'rnfisf' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='rnfisf' , -12. ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='rnfisf' , -12. ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iscpl ! land ice / ocean coupling option (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + nn_drown = 10 ! number of iteration of the extrapolation loop (fill the new wet cells) + ln_hsb = .false. ! activate conservation module (conservation exact after a time of rn_fiscpl) + nn_fiscpl = 43800 ! (number of time step) conservation period (maybe should be fix to the coupling frequencey of restart frequency) +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- + 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_wfr = 'sdw_ecwaves_orca2' , 6. , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6. , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .false. ! activate iceberg floats (force =F with "key_agrif") + ! + ! ! diagnostics: + ln_bergdia = .true. ! Calculate budgets + nn_verbose_level = 0 ! Turn on more verbose output if level > 0 + nn_verbose_write = 15 ! Timesteps between verbose messages + nn_sample_rate = 1 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 8.8e7, 4.1e8, 3.3e9, 1.8e10, 3.8e10, 7.5e10, 1.2e11, 2.2e11, 3.9e11, 7.4e11 + ! ! Proportion of calving mass to apportion to each class + rn_distribution = 0.24, 0.12, 0.15, 0.18, 0.12, 0.07, 0.03, 0.03, 0.03, 0.02 + ! ! Ratio between effective and real iceberg mass (non-dim) + ! ! i.e. number of icebergs represented at a point + rn_mass_scaling = 2000., 200., 50., 20., 10., 5., 2., 1., 1., 1. + ! thickness of newly calved bergs (m) + rn_initial_thickness = 40., 67., 133., 175., 250., 250., 250., 250., 250., 250. + ! + rn_rho_bergs = 850. ! Density of icebergs + rn_LoW_ratio = 1.5 ! Initial ratio L/W for newly calved icebergs + ln_operator_splitting = .true. ! Use first order operator splitting for thermodynamics + rn_bits_erosion_fraction = 0. ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0. ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0. ! CFL speed limit for a berg + + cn_dir = './' ! root directory for the calving 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_icb = 'calving' , -1. ,'calvingmask', .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) +!----------------------------------------------------------------------- + ! ! free slip ! partial slip ! no slip ! strong slip + rn_shlat = -9999. ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. + ln_shlat2d = .false. + cn_shlat2d_file = "empty" + cn_shlat2d_var = "empty" +/ +!----------------------------------------------------------------------- +&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 +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .false. ! Activate tides + ln_tide_pot = .false. ! use tidal potential forcing + ln_scal_load = .false. ! Use scalar approximation for + rn_scal_load = 0.094 ! load potential + ln_read_load = .false. ! Or read load potential from file + cn_tide_load = 'tide_LOAD_grid_T.nc' ! filename for load potential + ! + ln_tide_ramp = .false. ! Use linear ramp for tides at startup + rdttideramp = 0. ! ramp duration in days + clname(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .false. ! Use unstructured open boundaries + nb_bdy = 0 ! number of open boundary sets + ln_coords_file = .true. ! =T : read bdy coordinates from file + cn_coords_file = 'coordinates.bdy.nc' ! bdy coordinates files + ln_mask_file = .false. ! =T : read mask from file + cn_mask_file = '' ! name of mask file (if ln_mask_file=.TRUE.) + cn_dyn2d = 'none' ! + nn_dyn2d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! ! = 2, use tidal harmonic forcing data from files + ! ! = 3, use external data AND tidal harmonic forcing + cn_dyn3d = 'none' ! + nn_dyn3d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_tra = 'none' ! + nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_ice = 'none' ! + nn_ice_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! + ln_tra_dmp =.false. ! open boudaries conditions for tracers + ln_dyn3d_dmp =.false. ! open boundary condition for baroclinic velocities + rn_time_dmp = 1. ! Damping time scale in days + rn_time_dmp_out = 1. ! Outflow damping time scale + nn_rimwidth = 1 ! width of the relaxation zone + ln_vol = .false. ! total volume correction (see nn_volctl parameter) + nn_volctl = 1 ! = 0, the total water flux across open boundaries is zero +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data (see nam_bdy) +!----------------------------------------------------------------------- + ln_zinterp = .false. ! T if a vertical interpolation is required. Variables gdep[tuv] and e3[tuv] must exist in the file + ! ! automatically defined to T if the number of vertical levels in bdy dta /= jpk + ln_full_vel = .false. ! T if [uv]3d are "full" velocities and not only its baroclinic components + ! ! in this case, baroclinic and barotropic velocities will be recomputed -> [uv]2d not needed + ! + cn_dir = 'bdydta/' ! root directory for the BDY 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 ! + bn_ssh = 'amm12_bdyT_u2d' , 24. , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24. , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24. , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24. , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24. , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24. , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24. , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' , 24. , 'siconc' , .true. , .false., 'daily' , '' , '' , '' + bn_h_i = 'amm12_bdyT_ice' , 24. , 'sithic' , .true. , .false., 'daily' , '' , '' , '' + bn_h_s = 'amm12_bdyT_ice' , 24. , 'snthic' , .true. , .false., 'daily' , '' , '' , '' + bn_t_i = 'NOT USED' , 24. , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24. , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24. , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24. , 'sisalt' , .true. , .false., 'daily' , '' , '' , '' + ! melt ponds (be careful, bn_aip is the pond concentration (not fraction), so it differs from rn_iceapnd) + bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! -- salinity -- + rn_ice_age = 30. ! -- age -- + rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i -- + rn_ice_hpnd = 0.05 ! -- pond depth -- + rn_ice_hlid = 0.0 ! -- pond lid depth -- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries (default: OFF) +!----------------------------------------------------------------------- + filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. ! + ln_bdytide_conj = .false. ! +/ + +!!====================================================================== +!! *** 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_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot + ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) + ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ! + ln_drgimp = .true. ! implicit top/bottom friction flag + ln_drgice_imp = .false. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 1 constant flux + ! ! = 2 read variable flux [mW/m2] + rn_geoflx_cst = 86.4e-3 ! Constant value of geothermal heat 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 = .false. ! 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_teos10 = .true. ! = Use TEOS-10 + ln_eos80 = .false. ! = Use EOS80 + ln_seos = .false. ! = Use S-EOS (simplified Eq.) + ! + ! ! S-EOS coefficients (ln_seos=T): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 1.6550e-1 ! thermal expension coefficient + rn_b0 = 7.6554e-1 ! saline expension coefficient + rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 7.4914e-4 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 1.4970e-4 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.1090e-5 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 2.4341e-3 ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_OFF = .false. ! No tracer advection + ln_traadv_cen = .false. ! 2nd order centered scheme + nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_traadv_fct = .false. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + ln_traadv_mus = .false. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths + ln_traadv_ubs = .false. ! UBS scheme + nn_ubs_v = 2 ! =2 , vertical 2nd order FCT / COMPACT 4th order + ln_traadv_qck = .false. ! QUICKEST scheme +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .false. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator + ! + ! ! Direction of action: + ln_traldf_lev = .false. ! iso-level + ln_traldf_hor = .false. ! horizontal (geopotential) + ln_traldf_iso = .false. ! iso-neutral (standard operator) + ln_traldf_triad = .false. ! iso-neutral (triad operator) + ! + ! ! iso-neutral options: + ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators) + rn_slpmax = 0.01 ! slope limit (both operators) + ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only) + rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only) + ln_botmix_triad = .false. ! lateral mixing on bottom (triad only) + ! + ! ! Coefficients: + nn_aht_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing) + ! ! time invariant coefficients: aht0 = 1/2 Ud*Ld (lap case) + ! ! or = 1/12 Ud*Ld^3 (blp case) + rn_Ud = 0.01 ! 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 = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation + rn_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) + nn_mle = 1 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + rn_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) + nn_mld_uv = 0 ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + nn_conv = 0 ! =1 no MLE in case of convection ; =0 always MLE + rn_rho_c_mle = 0.01 ! delta rho criterion used to calculate MLD for FK +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_induced_velocity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.02 ! 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 =.false. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .false. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column + ! ! =1 no damping in the mixing layer (kz criteria) + ! ! =2 no damping in the mixed layer (rho crieria) + cn_resto = 'resto.nc' ! Name of file containing restoration coeff. field (use dmp_tools to create this) +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! z-star vertical coordinate + ln_vvl_ztilde = .false. ! z-tilde vertical coordinate: only high frequency variations + ln_vvl_layer = .false. ! full layer vertical coordinate + ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar + ln_vvl_zstar_at_eqtor = .false. ! ztilde near the equator + rn_ahe3 = 0.0 ! thickness diffusion coefficient + rn_rst_e3t = 30.0 ! ztilde to zstar restoration timescale [days] + rn_lf_cutoff = 5.0 ! cutoff frequency for low-pass filter [days] + rn_zdef_max = 0.9 ! maximum fractional e3t deformation + ln_vvl_dbg = .true. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .false. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .false. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! energy conserving scheme + ln_dynvor_ens = .false. ! enstrophy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_enT = .false. ! energy conserving scheme (T-point) + ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) + ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE + ! ! (f-point vorticity schemes only) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .false. ! z-coordinate - full steps + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .false. ! s-coordinate (standard jacobian formulation) + ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf + ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) + ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. ! explicit free surface + ln_dynspg_ts = .false. ! split-explicit free surface + ln_bt_fw = .true. ! Forward integration of barotropic Eqs. + ln_bt_av = .true. ! Time filtering of barotropic variables + nn_bt_flt = 1 ! Time filter choice = 0 None + ! ! = 1 Boxcar over nn_baro sub-steps + ! ! = 2 Boxcar over 2*nn_baro " " + ln_bt_auto = .true. ! Number of sub-step defined from: + rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds + rn_bt_alpha = 0. ! Temporal diffusion parameter (if ln_bt_av=F) +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) + ln_dynldf_lap = .false. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coefficient : + ! ! =-30 read in eddy_viscosity_3D.nc file + ! ! =-20 read in eddy_viscosity_2D.nc file + ! ! = 0 constant + ! ! = 10 F(k)=c1d + ! ! = 20 F(i,j)=F(grid spacing)=c2d + ! ! = 30 F(i,j,k)=c2d*c1d + ! ! = 31 F(i,j,k)=F(grid spacing and local velocity) + ! ! = 32 F(i,j,k)=F(local gridscale and deformation rate) + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.1 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) + ! ! Smagorinsky settings (nn_ahm_ijk_t= 32) : + rn_csmc = 3.5 ! Smagorinsky constant of proportionality + rn_minfac = 1.0 ! multiplier of theorectical lower limit + rn_maxfac = 1.0 ! multiplier of theorectical upper limit + ! ! iso-neutral laplacian operator (ln_dynldf_iso=T) : + rn_ahm_b = 0.0 ! background eddy viscosity [m2/s] +/ +!----------------------------------------------------------------------- +&namdta_dyn ! offline ocean input files (OFF_SRC only) +!----------------------------------------------------------------------- + ln_dynrnf = .false. ! runoffs option enabled (T) or not (F) + ln_dynrnf_depth = .false. ! runoffs is spread in vertical (T) or not (F) +! fwbcorr = 3.786e-06 ! annual global mean of empmr for ssh correction + + cn_dir = './' ! root directory for the ocean 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 = 'dyna_grid_T' , 120. , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120. , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120. , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120. , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120. , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120. , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120. , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120. , 'sobblcoy' , .true. , .true. , 'yearly' , '' , '' , '' +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! adaptive-implicit vertical advection + ln_zad_Aimp = .false. ! Courant number dependent scheme (Shchepetkin 2015) + ! + ! ! type of vertical closure (required) + ln_zdfcst = .false. ! constant mixing + ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) + ln_zdftke = .false. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfgls = .false. ! Generic Length Scale closure (T => fill namzdf_gls) + ln_zdfosm = .false. ! OSMOSIS BL closure (T => fill namzdf_osm) + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + nn_evdm = 0 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! mixing coefficient [m2/s] + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + nn_npc = 1 ! frequency of application of npc + nn_npcp = 365 ! npc control print frequency + ! + ln_zdfddm = .false. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ! + ! ! gravity wave-driven vertical mixing + ln_zdfiwm = .false. ! internal wave-induced mixing (T => fill namzdf_iwm) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 100.e-4 ! maximum value of the vertical viscosity + rn_alp = 5. ! coefficient of the parameterization + nn_ric = 2 ! coefficient of the parameterization + ln_mldw = .false. ! enhanced mixing in the Ekman layer + rn_ekmfc = 0.7 ! Factor in the Ekman depth Equation + rn_mldmin = 1.0 ! minimum allowable mixed-layer depth estimate (m) + rn_mldmax = 1000.0 ! maximum allowable mixed-layer depth estimate (m) + rn_wtmix = 10.0 ! vertical eddy viscosity coeff [m2/s] in the mixed-layer + rn_wvmix = 10.0 ! vertical eddy diffusion coeff [m2/s] in the mixed-layer +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + rn_ediff = 0.1 ! coef. for vertical eddy coef. (avt=rn_ediff*mxl*sqrt(e) ) + rn_ediss = 0.7 ! coef. of the Kolmogoroff dissipation + rn_ebb = 67.83 ! coef. of the surface input of tke (=67.83 suggested when ln_mxl0=T) + rn_emin = 1.e-6 ! minimum value of tke [m2/s2] + rn_emin0 = 1.e-4 ! surface minimum value of tke [m2/s2] + rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it) + nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm) + 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 + ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) + nn_mxlice = 2 ! type of scaling under sea-ice + ! = 0 no scaling under sea-ice + ! = 1 scaling with constant sea-ice thickness + ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) + ! = 3 scaling with maximum sea-ice thickness + rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) + rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value + ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002) + rn_lc = 0.15 ! coef. associated to Langmuir cells + 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) + rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) + nn_htau = 1 ! type of exponential decrease of tke penetration below the ML + ! = 0 constant 10 m length scale + ! = 1 0.5m at the equator to 30m poleward of 40 degrees + nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice + ! ! = 0 no impact of ice cover on langmuir & surface wave breaking + ! ! = 1 weigthed by 1-TANH(10*fr_i) + ! ! = 2 weighted by 1-fr_i + ! ! = 3 weighted by 1-MIN(1,4*fr_i) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1.e-7 ! minimum value of e [m2/s2] + rn_epsmin = 1.e-12 ! minimum value of eps [m2/s3] + ln_length_lim = .true. ! limit on the dissipation rate under stable stratification (Galperin et al., 1988) + rn_clim_galp = 0.267 ! galperin limit + ln_sigpsi = .true. ! Activate or not Burchard 2001 mods on psi schmidt number in the wb case + rn_crban = 100. ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000. ! Charnock constant for wb induced roughness length + rn_hsro = 0.02 ! Minimum surface roughness + rn_hsri = 0.03 ! Ice-ocean roughness + rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1) + nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) + ! ! = 3 requires ln_wave=T + nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice + ! ! = 0 no impact of ice cover + ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i) + ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i + ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i) + nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum) + nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum) + nn_stab_func = 2 ! stability function (0=Galp, 1= KC94, 2=CanutoA, 3=CanutoB) + nn_clos = 1 ! predefined closure type (0=MY82, 1=k-eps, 2=k-w, 3=Gen) +/ +!----------------------------------------------------------------------- +&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) +!----------------------------------------------------------------------- + ln_use_osm_la = .false. ! Use namelist rn_osm_la + rn_osm_la = 0.3 ! Turbulent Langmuir number + rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) + nn_ave = 0 ! choice of horizontal averaging on avt, avmu, avmv + ln_dia_osm = .true. ! output OSMOSIS-OBL variables + rn_osm_hbl0 = 10. ! initial hbl value + ln_kpprimix = .true. ! Use KPP-style Ri# mixing below BL + rn_riinfty = 0.7 ! Highest local Ri_g permitting shear instability + rn_difri = 0.005 ! max Ri# diffusivity at Ri_g = 0 (m^2/s) + ln_convmix = .true. ! Use convective instability mixing below BL + rn_difconv = 1. ! diffusivity when unstable below BL (m2/s) + nn_osm_wave = 0 ! Method used to calculate Stokes drift + ! ! = 2: Use ECMWF wave fields + ! ! = 1: Pierson Moskowitz wave spectrum + ! ! = 0: Constant La# = 0.3 +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) + ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency + ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) +/ + +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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_diaharm Harmonic analysis of tidal constituents (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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtrd ! trend diagnostics (default: OFF) +!----------------------------------------------------------------------- + ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE + ln_dyn_trd = .false. ! (T) 3D momentum trend output + ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet) + ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet) + ln_KE_trd = .false. ! (T) 3D Kinetic Energy trends + ln_PE_trd = .false. ! (T) 3D Potential Energy trends + ln_tra_trd = .false. ! (T) 3D tracer trend output + ln_tra_mxl = .false. ! (T) 2D tracer trends averaged over the mixed layer (not coded yet) + nn_trd = 365 ! print frequency (ln_glo_trd=T) (unit=time step) +/ +!!gm nn_ctls = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) +!!gm cn_trdrst_in = "restart_mld" ! suffix of ocean restart name (input) +!!gm cn_trdrst_out = "restart_mld" ! suffix of ocean restart name (output) +!!gm ln_trdmld_restart = .false. ! restart for ML diagnostics +!!gm ln_trdmld_instant = .false. ! flag to diagnose trends of instantantaneous or mean ML T/S +!!gm +!----------------------------------------------------------------------- +&namptr ! Poleward Transport Diagnostic (default: OFF) +!----------------------------------------------------------------------- + ln_diaptr = .false. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .false. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .false. ! output the heat and salt budgets (T) or not (F) +/ +!----------------------------------------------------------------------- +&namdiu ! Cool skin and warm layer models (default: OFF) +!----------------------------------------------------------------------- + ln_diurnal = .false. ! + ln_diurnal_only = .false. ! +/ +!----------------------------------------------------------------------- +&namflo ! float parameters (default: OFF) +!----------------------------------------------------------------------- + ln_floats = .false. ! activate floats or not + jpnfl = 1 ! total number of floats during the run + jpnnewflo = 0 ! number of floats for the restart + ln_rstflo = .false. ! float restart (T) or not (F) + nn_writefl = 75 ! frequency of writing in float output file + nn_stockfl = 5475 ! frequency of creation of the float restart file + ln_argo = .false. ! Argo type floats (stay at the surface each 10 days) + ln_flork4 = .false. ! trajectories computed with a 4th order Runge-Kutta (T) + ! ! or computed with Blanke' scheme (F) + ln_ariane = .true. ! Input with Ariane tool convention(T) + ln_flo_ascii= .true. ! Output with Ariane tool netcdf convention(F) or ascii file (T) +/ +!----------------------------------------------------------------------- +&nam_diaharm ! Harmonic analysis of tidal constituents (default: OFF) +!----------------------------------------------------------------------- + ln_diaharm = .false. ! Choose tidal harmonic output or not + nit000_han = 1 ! First time step used for harmonic analysis + nitend_han = 75 ! Last time step used for harmonic analysis + nstep_han = 15 ! Time step frequency for harmonic analysis + tname(1) = 'M2' ! Name of tidal constituents + tname(2) = 'K1' ! --- +/ +!----------------------------------------------------------------------- +&nam_diadct ! transports through some sections (default: OFF) +!----------------------------------------------------------------------- + ln_diadct = .false. ! Calculate transport thru sections or not + nn_dct = 15 ! time step frequency for transports computing + nn_dctwri = 15 ! time step frequency for transports writing + nn_secdebug = 112 ! 0 : no section to debug + ! ! -1 : debug all section + ! ! 0 < n : debug section number n +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default: OFF) +!----------------------------------------------------------------------- + ln_dia25h = .false. ! Choose 25h mean output or not +/ +!----------------------------------------------------------------------- +&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") +!----------------------------------------------------------------------- + nn_nchunks_i = 4 ! number of chunks in i-dimension + nn_nchunks_j = 4 ! number of chunks in j-dimension + nn_nchunks_k = 31 ! number of chunks in k-dimension + ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which + ! ! is optimal for postprocessing which works exclusively with horizontal slabs + ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression + ! ! (F) ignore chunking information and produce netcdf3-compatible files +/ + +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!----------------------------------------------------------------------- +&namobs ! observation usage switch (default: OFF) +!----------------------------------------------------------------------- + ln_diaobs = .false. ! Logical switch for the observation operator + ! + ln_t3d = .false. ! Logical switch for T profile observations + ln_s3d = .false. ! Logical switch for S profile observations + ln_sla = .false. ! Logical switch for SLA observations + ln_sst = .false. ! Logical switch for SST observations + ln_sss = .false. ! Logical swithc for SSS observations + ln_sic = .false. ! Logical switch for Sea Ice observations + ln_vel3d = .false. ! Logical switch for velocity observations + ln_altbias = .false. ! Logical switch for altimeter bias correction + ln_sstbias = .false. ! Logical switch for SST bias correction + ln_nea = .false. ! Logical switch for rejection of observations near land + ln_grid_global = .true. ! Logical switch for global distribution of observations + ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table + ln_ignmis = .true. ! Logical switch for ignoring missing files + ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there + ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs + ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. + ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres + ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres + ln_sss_fp_indegs = .true. ! Logical for SSS: T=> averaging footprint is in degrees, F=> in metres + ln_sic_fp_indegs = .true. ! Logical for SIC: T=> averaging footprint is in degrees, F=> in metres +! All of the *files* variables below are arrays. Use namelist_cfg to add more files + cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names + cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names + cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names + cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names + cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names + cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names + cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name + cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file name + cn_gridsearchfile ='gridsearch.nc' ! Grid search file name + rn_gridsearchres = 0.5 ! Grid search resolution + rn_mdtcorr = 1.61 ! MDT correction + rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction + rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) + nn_1dint = 0 ! Type of vertical interpolation method + nn_2dint = 0 ! Default horizontal interpolation method + nn_2dint_sla = 0 ! Horizontal interpolation method for SLA + nn_2dint_sst = 0 ! Horizontal interpolation method for SST + nn_2dint_sss = 0 ! Horizontal interpolation method for SSS + nn_2dint_sic = 0 ! Horizontal interpolation method for SIC + nn_msshc = 0 ! MSSH correction scheme + nn_profdavtypes = -1 ! Profile daily average types - array +/ +!----------------------------------------------------------------------- +&nam_asminc ! assimilation increments ('key_asminc') +!----------------------------------------------------------------------- + ln_bkgwri = .false. ! Logical switch for writing out background state + ln_trainc = .false. ! Logical switch for applying tracer increments + ln_dyninc = .false. ! Logical switch for applying velocity increments + ln_sshinc = .false. ! Logical switch for applying SSH increments + ln_asmdin = .false. ! Logical switch for Direct Initialization (DI) + ln_asmiau = .false. ! Logical switch for Incremental Analysis Updating (IAU) + nitbkg = 0 ! Timestep of background in [0,nitend-nit000-1] + nitdin = 0 ! Timestep of background for DI in [0,nitend-nit000-1] + nitiaustr = 1 ! Timestep of start of IAU interval in [0,nitend-nit000-1] + nitiaufin = 15 ! Timestep of end of IAU interval in [0,nitend-nit000-1] + niaufn = 0 ! Type of IAU weighting function + ln_salfix = .false. ! Logical switch for ensuring that the sa > salfixmin + salfixmin = -9999 ! Minimum salinity after applying the increments + nn_divdmp = 0 ! Number of iterations of divergence damping operator +/ + +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_listonly = .false. ! do nothing else than listing the best domain decompositions (with land domains suppression) + ! ! if T: the largest number of cores tested is defined by max(mppsize, jpni*jpnj) + ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold + jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T + sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following + sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings. + sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure + sn_cfctl%l_oceout = .FALSE. ! that all areas report. + sn_cfctl%l_layout = .FALSE. ! + sn_cfctl%l_mppout = .FALSE. ! + sn_cfctl%l_mpptop = .FALSE. ! + sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0] + sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000] + sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1] + sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info + nn_print = 0 ! level of print (0 no extra print) + nn_ictls = 0 ! start i indice of control sum (use to compare mono versus + nn_ictle = 0 ! end i indice of control sum multi processor runs + nn_jctls = 0 ! start j indice of control over a subdomain) + nn_jctle = 0 ! end j indice of control + nn_isplt = 1 ! number of processors in i-direction + nn_jsplt = 1 ! number of processors in j-direction + ln_timing = .false. ! timing by routine write out in timing.output file + ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- + ln_sto_eos = .false. ! stochastic equation of state + nn_sto_eos = 1 ! number of independent random walks + rn_eos_stdxy = 1.4 ! random walk horz. standard deviation (in grid points) + rn_eos_stdz = 0.7 ! random walk vert. standard deviation (in grid points) + rn_eos_tcor = 1440. ! random walk time correlation (in timesteps) + nn_eos_ord = 1 ! order of autoregressive processes + nn_eos_flt = 0 ! passes of Laplacian filter + rn_eos_lim = 2.0 ! limitation factor (default = 3.0) + ln_rststo = .false. ! start from mean parameter (F) or from restart file (T) + ln_rstseed = .true. ! read seed of RNG from restart file + cn_storst_in = "restart_sto" ! suffix of stochastic parameter restart file (input) + cn_storst_out = "restart_sto" ! suffix of stochastic parameter restart file (output) +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/nemo b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/nemo new file mode 120000 index 0000000..170c312 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/nemo @@ -0,0 +1 @@ +/work/n01/n01/jelt/AMM7_SURGE/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/BLD/bin/nemo.exe \ No newline at end of file diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/runscript.slurm b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/runscript.slurm new file mode 100644 index 0000000..15589bb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/runscript.slurm @@ -0,0 +1,46 @@ +#!/bin/bash +#SBATCH --job-name=SRG_ERA5 +#SBATCH --time=00:30:00 +#SBATCH --nodes=2 +#SBATCH --ntasks-per-core=1 +#SBATCH --account=n01-class +#SBATCH --partition=standard +#SBATCH --qos=standard +#SBATCH -o %A_%a.out +#SBATCH -e %A_%a.err + +start=`date +%s` + +# Created by: mkslurm_hetjob -S 4 -s 16 -m 2 -C 96 -g 2 -N 128 -t 00:10:00 -a n01 -j nemo_test -v False +#module swap PrgEnv-cray/8.0.0 PrgEnv-gnu/8.1.0 +#module swap craype-network-ofi craype-network-ucx +#module swap cray-mpich cray-mpich-ucx +#module load cray-hdf5-parallel/1.12.0.7 +#module load cray-netcdf-hdf5parallel/4.7.4.7 +#module load libfabric +#module list +export OMP_NUM_THREADS=1 + +cat > myscript_wrapper.sh << EOFB +#!/bin/ksh +# +set -A map ./xios_server.exe ./nemo +exec_map=( 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) +# +exec \${map[\${exec_map[\$SLURM_PROCID]}]} +## +EOFB +chmod u+x ./myscript_wrapper.sh + +srun --mem-bind=local \ +--ntasks=100 --ntasks-per-node=50 --cpu-bind=v,mask_cpu:0x1,0x10000,0x100000000,0x400000000,0x1000000000,0x4000000000,0x10000000000,0x40000000000,0x100000000000,0x400000000000,0x1000000000000,0x4000000000000,0x10000000000000,0x40000000000000,0x100000000000000,0x400000000000000,0x1000000000000000,0x4000000000000000,0x10000000000000000,0x40000000000000000,0x100000000000000000,0x400000000000000000,0x1000000000000000000,0x4000000000000000000,0x10000000000000000000,0x40000000000000000000,0x100000000000000000000,0x400000000000000000000,0x1000000000000000000000,0x4000000000000000000000,0x10000000000000000000000,0x40000000000000000000000,0x100000000000000000000000,0x400000000000000000000000,0x1000000000000000000000000,0x4000000000000000000000000,0x10000000000000000000000000,0x40000000000000000000000000,0x100000000000000000000000000,0x400000000000000000000000000,0x1000000000000000000000000000,0x4000000000000000000000000000,0x10000000000000000000000000000,0x40000000000000000000000000000,0x100000000000000000000000000000,0x400000000000000000000000000000,0x1000000000000000000000000000000,0x4000000000000000000000000000000,0x10000000000000000000000000000000,0x40000000000000000000000000000000 ./myscript_wrapper.sh + + +end=`date +%s` +runtime=$((end-start)) +hours=$((runtime / 3600)) +minutes=$(( (runtime % 3600) / 60 )) +seconds=$(( (runtime % 3600) % 60 )) +echo "Runtime: $hours:$minutes:$seconds (hh:mm:ss)" +wait +exit diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/runscript_anemone.slurm b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/runscript_anemone.slurm new file mode 100644 index 0000000..7755a6d --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/runscript_anemone.slurm @@ -0,0 +1,21 @@ +#!/bin/bash +#SBATCH --job-name=AMM7-S +#SBATCH --partition=compute +#SBATCH --time=00:30:00 +#SBATCH --ntasks-per-core=1 +#SBATCH --ntasks-per-node=64 +#SBATCH --ntasks-per-socket=32 +#SBATCH --nodes=2 + + +module load NEMO/prg-env + +echo $PWD + +export OMP_NUM_THREADS=1 +export I_MPI_SHM=off +unset I_MPI_PMI_LIBRARY + +mpiexec.hydra -print-rank-map -ppn 1 -np 16 ./xios_server.exe : -np 96 ./nemo + +exit diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/xios_server.exe b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/xios_server.exe new file mode 120000 index 0000000..b4fca65 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO/xios_server.exe @@ -0,0 +1 @@ +/work/n01/shared/nemo/XIOS2_Cray/bin/xios_server.exe \ No newline at end of file diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/RESTARTS/README.txt b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/RESTARTS/README.txt new file mode 100644 index 0000000..18b4d3f --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/RESTARTS/README.txt @@ -0,0 +1 @@ +directory for storing restart files diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/bdydta b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/bdydta new file mode 120000 index 0000000..c6bb8c1 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/bdydta @@ -0,0 +1 @@ +/work/n01/n01/shared/CO_AMM7/TIDE/FES \ No newline at end of file diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/context_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/context_nemo.xml new file mode 100644 index 0000000..a12b8bd --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/context_nemo.xml @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/domain_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/domain_def_nemo.xml new file mode 100644 index 0000000..0931e2b --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/domain_def_nemo.xml @@ -0,0 +1,198 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/field_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/field_def_nemo-oce.xml new file mode 100644 index 0000000..62b0bb6 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/field_def_nemo-oce.xml @@ -0,0 +1,1129 @@ + + + + + + + + + + + + + + + + + + + + + + + toce_pot * e3t + + soce_pra * e3t + + + toce_con * e3t + + soce_abs * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + sst_pot * sst_pot + + + + + + + + + + + + sss_pra * sss_pra + + + + + + + sst_con * sst_con + + + + + + + + + + + + sss_abs * sss_abs + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + uoce * uoce * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + voce * voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + ut * e3u + + us * e3u + + urhop * e3u + + vt * e3v + + vs * e3v + + vrhop * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + @voce_e3v + + this * e1v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sophtvtr - sophtove + sophtvtr - sopstove + + + + + + + + + + + + + + + + + + + ttrd_atf * e3t + strd_atf * e3t + + ttrd_atf_e3t * 1026.0 * 3991.86795711963 + strd_atf_e3t * 1026.0 * 0.001 + + + + + + + + + + + sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) + sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) + + + + + + + + + + + + + ttrd_ldf + ttrd_zdf - ttrd_zdfp + strd_ldf + strd_zdf - strd_zdfp + + + + + + + + + + + + + + + + + ttrd_xad * e3t + strd_xad * e3t + ttrd_yad * e3t + strd_yad * e3t + ttrd_zad * e3t + strd_zad * e3t + ttrd_ad * e3t + strd_ad * e3t + ttrd_totad * e3t + strd_totad * e3t + ttrd_ldf * e3t + strd_ldf * e3t + ttrd_zdf * e3t + strd_zdf * e3t + ttrd_evd * e3t + strd_evd * e3t + + + ttrd_iso * e3t + strd_iso * e3t + ttrd_zdfp * e3t + strd_zdfp * e3t + + + ttrd_dmp * e3t + strd_dmp * e3t + ttrd_bbl * e3t + strd_bbl * e3t + ttrd_npc * e3t + strd_npc * e3t + ttrd_qns * e3ts + strd_cdt * e3ts + ttrd_qsr * e3t + ttrd_bbc * e3t + + + ttrd_totad_e3t * 1026.0 * 3991.86795711963 + strd_totad_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + ttrd_iso_e3t * 1026.0 * 3991.86795711963 + strd_iso_e3t * 1026.0 * 0.001 + ttrd_zdfp_e3t * 1026.0 * 3991.86795711963 + strd_zdfp_e3t * 1026.0 * 0.001 + ttrd_qns_e3t * 1026.0 * 3991.86795711963 + ttrd_qsr_e3t * 1026.0 * 3991.86795711963 + ttrd_bbl_e3t * 1026.0 * 3991.86795711963 + strd_bbl_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + + + + + + + + + ttrd_tot * e3t + strd_tot * e3t + + ttrd_tot_e3t * 1026.0 * 3991.86795711963 + strd_tot_e3t * 1026.0 * 0.001 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/field_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/field_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/file_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/file_def_nemo-oce.xml new file mode 100644 index 0000000..beb06e6 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/file_def_nemo-oce.xml @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/file_def_nemo-opa.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/file_def_nemo-opa.xml new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/fluxes b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/fluxes new file mode 120000 index 0000000..c658678 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/fluxes @@ -0,0 +1 @@ +/work/n01/n01/shared/CO_AMM15/INPUTS/forcing/era5 \ No newline at end of file diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/grid_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/grid_def_nemo.xml new file mode 100644 index 0000000..b370feb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/grid_def_nemo.xml @@ -0,0 +1,180 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/iodef.xml b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/iodef.xml new file mode 100644 index 0000000..8bfff14 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/iodef.xml @@ -0,0 +1,26 @@ + + + + + + + + + + + + -1 + true + false + oceanx + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/myscript_wrapper.sh b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/myscript_wrapper.sh new file mode 100755 index 0000000..87e905e --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/myscript_wrapper.sh @@ -0,0 +1,7 @@ +#!/bin/ksh +# +set -A map ./xios_server.exe ./nemo +exec_map=( 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) +# +exec ${map[${exec_map[$SLURM_PROCID]}]} +## diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/namelist_cfg b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/namelist_cfg new file mode 100644 index 0000000..86a47a9 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/namelist_cfg @@ -0,0 +1,366 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE Configuration namelist : overwrite default values defined in SHARED/namelist_ref +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! AMM12 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + cn_exp = "AMMSRG_no" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 7008 ! 52560 ! last time step (std 1 day = 192) + nn_date0 = 20170101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_leapy = 1 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "./RESTARTS" ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "./RESTARTS" ! directory in which to write output ocean restarts + nn_stock = 70080 ! frequency of creation of a restart file (modulo referenced to 1) + nn_write = 192 ! 52560 ! frequency of write in the output file (modulo referenced to nit000) +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + rn_rdt = 450. ! time step for the dynamics (and tracer if nn_acc=0) + ln_2d = .true. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: user defined GYRE) +!----------------------------------------------------------------------- + ln_read_cfg = .true. ! (=T) read the domain configuration file + cn_domcfg = "amm7_surge_domain_cfg" ! domain configuration filename +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells +/ +!!====================================================================== +!! *** 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 (surface module) (default: NO selection) +!----------------------------------------------------------------------- + nn_fsbc = 1 ! frequency of SBC module call + ln_usr = .true. + ln_flx = .false. ! flux formulation (T => fill namsbc_flx) + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) +/ +!----------------------------------------------------------------------- +&namsbc_usr ! namsbc_surge surge model fluxes +!----------------------------------------------------------------------- + ln_use_sbc = .false. ! (T) to turn on surge fluxes (wind and pressure only) + ! (F) for no fluxes (ie tide only case) + +! +! ! file name ! frequency (hours) ! variable ! time interp. ! clim ! 'yearly'/ ! weights ! rotation ! +! ! ! (if <0 months) ! name ! (logical) ! (T/F) ! 'monthly' ! filename ! pairing ! + sn_wndi = 'ERA5_U10' , 1 ,'U10', .true. , .false. , 'yearly' ,'weights_era5_bicubic.nc' , 'Uwnd', 'ERA5_LSM' + sn_wndj = 'ERA5_V10' , 1 ,'V10', .true. , .false. , 'yearly' ,'weights_era5_bicubic.nc' , 'Vwnd' , 'ERA5_LSM' + cn_dir = './fluxes/' ! root directory for the location of the bulk files + rn_vfac = 1. ! multiplicative factor for ocean/ice velocity + ! in the calculation of the wind stress (0.=absolute winds or 1.=relative winds) + rn_charn_const = 0.0275 +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101200. ! reference atmospheric pressure [N/m2] + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .true. ! inverse barometer added to OBC ssh data + + cn_dir = './fluxes/' ! root directory for the Patm 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_apr = 'ERA5_MSL' , 1 , 'MSL' , .true. , .false., 'yearly' , 'weights_era5_bicubic.nc', 'Uwnd' , 'ERA5_LSM' +/ +!!====================================================================== +!! *** 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 = 0 ! free slip +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .true. + clname(1) = 'M2' ! name of constituent + clname(2) = 'S2' + clname(3) = 'K2' +! clname(1) ='2N2' +! clname(2)='EPS2' +! clname(3)='J1' +! clname(4)='K1' +! clname(5)='K2' +! clname(6)='L2' +! clname(7)='LA2' +! clname(8)='M2' +! clname(9)='M3' +! clname(10)='M4' +! clname(11)='M6' +! clname(12)='M8' +! clname(13)='MF' +! clname(14)='MKS2' +! clname(15)='MM' +! clname(16)='MN4' +! clname(17)='MS4' +! clname(18)='MSF' +! clname(19)='MSQM' +! clname(20)='MTM' +! clname(21)='MU2' +! clname(22)='N2' +! clname(23)='N4' +! clname(24)='NU2' +! clname(25)='O1' +! clname(26)='P1' +! clname(27)='Q1' +! clname(28)='R2' +! clname(29)='S1' +! clname(30)='S2' +! clname(31)='S4' +! clname(32)='SA' +! clname(33)='SSA' +! clname(34)='T2' +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .true. + nb_bdy = 1 ! number of open boundary sets + cn_dyn2d = 'flather' ! + nn_dyn2d_dta = 2 ! = 0, bdy data are equal to the initial state + ! = 1, bdy data are read in 'bdydata .nc' files + ! = 2, use tidal harmonic forcing data from files + ! = 3, use external data AND tidal harmonic forcing +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries +!----------------------------------------------------------------------- + filtide = 'bdydta/AMM7_surge_bdytide_rotT_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. +/ +!!====================================================================== +!! *** Top/Bottom boundary condition *** !! +!! !! +!! namdrg top/bottom drag coefficient (default: NO selection) +!! namdrg_top top friction (ln_OFF =F & ln_isfcav=T) +!! namdrg_bot bottom friction (ln_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_non_lin = .true. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction +!----------------------------------------------------------------------- + rn_Cd0 = 2.4e-3 ! CO'N used 1e-5 with ln_boost field (4Jan24) ! drag coefficient [-] + rn_ke0 = 0.0e0 ! background kinetic energy [m2/s2] (non-linear cases) + ln_boost = .false., + rn_boost = 1., +/ +!!====================================================================== +!! 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_teos10 = .true. ! = Use TEOS-10 equation of state +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_vec = .true. ! vector form (T) or flux form (F) +/ +!----------------------------------------------------------------------- +&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 scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_ts = .true. ! split-explicit free surface + ln_bt_auto = .true. ! Number of sub-step defined from: +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ln_dynldf_blp = .true. ! bilaplacian operator + ln_dynldf_lap = .false. ! bilaplacian operator + ln_dynldf_lev = .true. ! iso-level + nn_ahm_ijk_t = 0 ! =0 constant = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.012 ! lateral viscous velocity [m/s] + rn_Lv = 1.e+4 ! lateral viscous length [m] +/ +!!====================================================================== +!! 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 (default: NO selection) +!----------------------------------------------------------------------- + rn_avm0 = 0.1e-6 ! vertical eddy viscosity [m2/s] (background Kz if ln_zdfcst=F) + rn_avt0 = 0.1e-6 ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_charn = 100000. ! Charnock constant for wb induced roughness length + nn_z0_met = 1 ! Method for surface roughness computation (0/1/2) +/ +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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 ("key_float") +!! nam_diaharm Harmonic analysis of tidal constituents ("key_diaharm") +!! namdct transports through some sections ("key_diadct") +!! nam_diatmb Top Middle Bottom Output (default: OFF) +!! nam_dia25h 25h Mean Output (default: OFF) +!! namnc4 netcdf4 chunking and compression settings ("key_netcdf4") +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_diatmb ! Top Middle Bottom Output (default F) +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default F) +!----------------------------------------------------------------------- +/ +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .false. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/namelist_ref b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/namelist_ref new file mode 100644 index 0000000..f962f37 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/namelist_ref @@ -0,0 +1,1386 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : Reference namelist_ref !! +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : 1 - Domain & run manager (namrun, namcfg, namdom, namtsd, namcrs, namc1d, namc1d_uvd) +!! namelists 2 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_cpl, +!! namsbc_sas, namtra_qsr, namsbc_rnf, +!! namsbc_isf, namsbc_iscpl, namsbc_apr, +!! namsbc_ssr, namsbc_wave, namberg) +!! 3 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide) +!! 4 - top/bot boundary (namdrg, namdrg_top, namdrg_bot, nambbc, nambbl) +!! 5 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_eiv, namtra_dmp) +!! 6 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) +!! 7 - Vertical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_gls, namzdf_iwm) +!! 8 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb) +!! 9 - Obs & Assim (namobs, nam_asminc) +!! 10 - miscellaneous (nammpp, namctl, namsto) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!!====================================================================== +!! *** 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! Assimilation cycle index + cn_exp = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5840) + nn_date0 = 010101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_time0 = 0 ! initial time of day in hhmm + nn_leapy = 0 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T + nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T + ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist + ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart + ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "." ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "." ! directory in which to write output ocean restarts + ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model + nn_istate = 0 ! output the initial state (1) or not (0) + ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) + nn_stock = 0 ! used only if ln_rst_list = F: output restart freqeuncy (modulo referenced to 1) + ! ! = 0 force to write restart files only at the end of the run + ! ! = -1 do not do any restart + nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written + nn_write = 0 ! used only if key_iomput is not defined: output frequency (modulo referenced to nn_it000) + ! ! = 0 force to write output files only at the end of the run + ! ! = -1 do not do any output file + ln_mskland = .false. ! mask land points in NetCDF outputs + ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + ln_xios_read = .FALSE. ! use XIOS to read restart file (only for a single file restart) + nn_wxios = 0 ! use XIOS to write restart file 0 - no, 1 - single file output, 2 - multiple file output + ln_rst_eos = .TRUE. ! check if the equation of state used to produce the restart is consistent with model +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.00 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 5400. ! time step for the dynamics and tracer + rn_atfp = 0.1 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_2d = .false. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration (F => create/check namusr_def) + cn_domcfg = "domain_cfg" ! domain configuration filename + ! + ln_closea = .false. ! T => keep closed seas (defined by closea_mask field) in the + ! ! domain and apply special treatment of freshwater fluxes. + ! ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. + ! ! If closea_mask field doesn't exist in the domain_cfg file + ! ! then this logical does nothing. + ln_write_cfg = .false. ! (=T) create the domain configuration file + cn_domcfg_out = "domain_cfg_out" ! newly created domain configuration filename + ! + ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present + ! ! in netcdf input files, as the start j-row for reading +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .false. ! ocean initialisation + ln_tsd_dmp = .false. ! 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' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_il = .false. ! T/F activation of iterative limiter + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells + rn_wdld = 2.5 ! Land elevation below which WaD is allowed + nn_wdit = 20 ! Max iterations for WaD limiter + rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes + rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) +/ +!----------------------------------------------------------------------- +&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T) +!----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_binref = 0 ! Bin centering preference: NORTH or EQUAT + ! ! 0, coarse grid is binned with preferential treatment of the north fold + ! ! 1, coarse grid is binned with centering at the equator + ! ! Symmetry with nn_facty being odd-numbered. Asymmetry with even-numbered nn_facty. + ln_msh_crs = .false. ! =T create a mesh & mask file + nn_crs_kz = 0 ! 0, MEAN of volume boxes + ! ! 1, MAX of boxes + ! ! 2, MIN of boxes + ln_crs_wn = .true. ! wn coarsened (T) or computed using horizontal divergence ( F ) +/ +!----------------------------------------------------------------------- +&namc1d ! 1D configuration options ("key_c1d" default: PAPA station) +!----------------------------------------------------------------------- + rn_lat1d = 50 ! Column latitude + rn_lon1d = -145 ! Column longitude + ln_c1d_locpt = .true. ! Localization of 1D config in a grid (T) or independant point (F) +/ +!----------------------------------------------------------------------- +&namc1d_dyndmp ! U & V newtonian damping ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ln_dyndmp = .false. ! add a damping term (T) or not (F) +/ +!----------------------------------------------------------------------- +&namc1d_uvd ! data: U & V currents ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ! ! =T read U-V fields for: + ln_uvd_init = .false. ! ocean initialisation + ln_uvd_dyndmp = .false. ! U-V restoring + + cn_dir = './' ! root directory for the U-V 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_ucur = 'ucurrent' , -1. ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' + sn_vcur = 'vcurrent' , -1. ,'v_current', .false. , .true. , 'monthly' , '' , 'Vme' , '' +/ + +!!====================================================================== +!! *** 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 = 2 ! frequency of SBC module call + ! ! (control sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_usr = .false. ! user defined formulation (T => check usrdef_sbc) + ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + ! ! Type of coupling (Ocean/Ice/Atmosphere) : + ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) + ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) + nn_components = 0 ! configuration of the opa-sas OASIS coupling + ! ! =0 no opa-sas OASIS coupling: default single executable config. + ! ! =1 opa-sas OASIS coupling: multi executable config., OPA component + ! ! =2 opa-sas OASIS coupling: multi executable config., SAS component + ! Sea-ice : + nn_ice = 0 ! =0 no ice boundary condition + ! ! =1 use observed ice-cover ( => fill namsbc_iif ) + ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice") + ! ! except in AGRIF zoom where it has to be specified + ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges) + ! ! =F levitating ice (no pressure, mass and salt exchanges) + ! Misc. options of sbc : + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked + ! ! =1 global mean of e-p-r set to zero at each time step + ! ! =2 annual global mean of e-p-r set to zero + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .false. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave) + nn_sdrift = 0 ! Parameterization for the calculation of 3D-Stokes drift from the surface Stokes drift + ! ! = 0 Breivik 2015 parameterization: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] + ! ! = 1 Phillips: v_z=v_o*[exp(2*k*z)-beta*sqrt(-2*k*pi*z)*erfc(sqrt(-2*k*z))] + ! ! = 2 Phillips as (1) but using the wave frequency from a wave model + ln_tauwoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave) + ln_tauw = .false. ! Activate ocean stress components from wave model + ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) + nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , + ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) +/ +!----------------------------------------------------------------------- +&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the fluxes 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_utau = 'utau' , 24. , 'utau' , .false. , .false., 'yearly' , '' , '' , '' + sn_vtau = 'vtau' , 24. , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' + sn_qtot = 'qtot' , 24. , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' + sn_qsr = 'qsr' , 24. , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' + sn_emp = 'emp' , 24. , 'emp' , .false. , .false., 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .false. ! "NCAR" algorithm (Large and Yeager 2008) + ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) + ln_COARE_3p5 = .false. ! "COARE 3.5" algorithm (Edson et al. 2013) + ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) + ! + rn_zqt = 10. ! Air temperature & humidity reference height (m) + rn_zu = 10. ! Wind vector reference height (m) + ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012) + ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015) + ln_taudif = .false. ! HF tau contribution: use "mean of stress module - module of the mean stress" data + rn_pfac = 1. ! multiplicative factor for precipitation (total & snow) + rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to + ! ! calculate the wind stress (0.=absolute or 1.=relative winds) + + 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_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' + sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' + sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tdif = 'taudif_core' , 24. , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") +!----------------------------------------------------------------------- + nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data + ln_usecplmask = .false. ! 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) + ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1) + !_____________!__________________________!____________!_____________!______________________!________! + ! ! description ! multiple ! vector ! vector ! vector ! + ! ! ! categories ! reference ! orientation ! grids ! +!*** send *** + sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , '' + sn_snd_alb = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick = 'none' , 'no' , '' , '' , '' + sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' + sn_snd_co2 = 'coupled' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick1 = 'ice and snow' , 'no' , '' , '' , '' + sn_snd_mpnd = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_sstfrz = 'coupled' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'no' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'none' , 'no' , '' , '' , '' + sn_rcv_taumod = 'coupled' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , 'U,V' + sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'no' , '' , '' , '' + sn_rcv_rnf = 'coupled' , 'no' , '' , '' , '' + sn_rcv_cal = 'coupled' , 'no' , '' , '' , '' + sn_rcv_co2 = 'coupled' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'none' , 'no' , '' , '' , '' + sn_rcv_mslp = 'none' , 'no' , '' , '' , '' + sn_rcv_phioc = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfx = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfy = 'none' , 'no' , '' , '' , '' + sn_rcv_wper = 'none' , 'no' , '' , '' , '' + sn_rcv_wnum = 'none' , 'no' , '' , '' , '' + sn_rcv_wfreq = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' + sn_rcv_ts_ice = 'none' , 'no' , '' , '' , '' + sn_rcv_isf = 'none' , 'no' , '' , '' , '' + sn_rcv_icb = 'none' , 'no' , '' , '' , '' + sn_rcv_tauwoc = 'none' , 'no' , '' , '' , '' + sn_rcv_tauw = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .true. ! =T Read in file ; =F set all to 0. (see sbcssm) + ln_3d_uve = .false. ! specify whether we are supplying a 3D u,v and e3 field + ln_read_frq = .false. ! specify whether we must read frq or not + + cn_dir = './' ! root directory for the ocean 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_usp = 'sas_grid_U' , 120. , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsp = 'sas_grid_V' , 120. , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tem = 'sas_grid_T' , 120. , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sas_grid_T' , 120. , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_ssh = 'sas_grid_T' , 120. , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' + sn_e3t = 'sas_grid_T' , 120. , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' + sn_frq = 'sas_grid_T' , 120. , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the ice cover 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_ice ='ice_cover_clim.nc' , -12. ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .false. ! RGB light penetration (Red-Green-Blue) + ln_qsr_2bd = .false. ! 2BD light penetration (two bands) + ln_qsr_bio = .false. ! bio-model light penetration + ! ! RGB & 2BD choices: + rn_abs = 0.58 ! RGB & 2BD: fraction absorbed in the very near surface + rn_si0 = 0.35 ! RGB & 2BD: shortess depth of extinction + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) + rn_si1 = 23.0 ! 2BD : longest depth of extinction + + 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_sstr = 0 ! add a retroaction term to the surface heat flux (=1) or not (=0) + rn_dqdt = -40. ! magnitude of the retroaction on temperature [W/m2/K] + nn_sssr = 0 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + 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] + nn_sssr_ice = 1 ! control of sea surface restoring under sea-ice + ! 0 = no restoration under ice : * (1-icefrac) + ! 1 = restoration everywhere + ! >1 = enhanced restoration under ice : 1+(nn_icedmp-1)*icefrac + cn_dir = './' ! root directory for the SST/SSS 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_sst = 'sst_data' , 24. , 'sst' , .false. , .false., 'yearly' , '' , '' , '' + sn_sss = 'sss_data' , -1. , 'sss' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .false. ! 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 + ln_rnf_depth = .false. ! read in depth information for runoff + ln_rnf_tem = .false. ! read in temperature information for runoff + ln_rnf_sal = .false. ! read in salinity information for runoff + ln_rnf_depth_ini = .false. ! compute depth at initialisation from runoff file + rn_rnf_max = 5.735e-4 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150. ! depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) + nn_rnf_depth_file = 0 ! create (=1) a runoff depth file or not (=0) + ln_rnf_icb = .false. ! read in iceberg flux from a file (fill sn_i_rnf if .true.) + + cn_dir = './' ! root directory for the runoff 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_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' , '' , '' , '' + sn_i_rnf = 'NOT_USED' , -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000. ! reference atmospheric pressure [N/m2]/ + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .false. ! inverse barometer added to OBC ssh data + + cn_dir = './' ! root directory for the Patm 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_apr = 'patm' , -1. ,'somslpre' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_isf ! Top boundary layer (ISF) (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + ! ! type of top boundary layer + nn_isf = 1 ! ice shelf melting/freezing + ! 1 = presence of ISF ; 2 = bg03 parametrisation + ! 3 = rnf file for ISF ; 4 = ISF specified freshwater flux + ! options 1 and 4 need ln_isfcav = .true. (domzgr) + ! ! nn_isf = 1 or 2 cases: + rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula + rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) + ! ! 0 => thickness of the tbl = thickness of the first wet cell + ! ! nn_isf = 1 case + nn_isfblk = 1 ! 1 ISOMIP like: 2 equations formulation (Hunter et al., 2006) + ! ! 2 ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) + nn_gammablk = 1 ! 0 = cst Gammat (= gammat/s) + ! ! 1 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) + ! ! 2 = velocity and stability dependent Gamma (Holland et al. 1999) + + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! 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 ! +!* nn_isf = 4 case + sn_fwfisf = 'rnfisf' , -12. ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'rnfisf' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='rnfisf' , -12. ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='rnfisf' , -12. ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iscpl ! land ice / ocean coupling option (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + nn_drown = 10 ! number of iteration of the extrapolation loop (fill the new wet cells) + ln_hsb = .false. ! activate conservation module (conservation exact after a time of rn_fiscpl) + nn_fiscpl = 43800 ! (number of time step) conservation period (maybe should be fix to the coupling frequencey of restart frequency) +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- + 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_wfr = 'sdw_ecwaves_orca2' , 6. , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6. , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .false. ! activate iceberg floats (force =F with "key_agrif") + ! + ! ! diagnostics: + ln_bergdia = .true. ! Calculate budgets + nn_verbose_level = 0 ! Turn on more verbose output if level > 0 + nn_verbose_write = 15 ! Timesteps between verbose messages + nn_sample_rate = 1 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 8.8e7, 4.1e8, 3.3e9, 1.8e10, 3.8e10, 7.5e10, 1.2e11, 2.2e11, 3.9e11, 7.4e11 + ! ! Proportion of calving mass to apportion to each class + rn_distribution = 0.24, 0.12, 0.15, 0.18, 0.12, 0.07, 0.03, 0.03, 0.03, 0.02 + ! ! Ratio between effective and real iceberg mass (non-dim) + ! ! i.e. number of icebergs represented at a point + rn_mass_scaling = 2000., 200., 50., 20., 10., 5., 2., 1., 1., 1. + ! thickness of newly calved bergs (m) + rn_initial_thickness = 40., 67., 133., 175., 250., 250., 250., 250., 250., 250. + ! + rn_rho_bergs = 850. ! Density of icebergs + rn_LoW_ratio = 1.5 ! Initial ratio L/W for newly calved icebergs + ln_operator_splitting = .true. ! Use first order operator splitting for thermodynamics + rn_bits_erosion_fraction = 0. ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0. ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0. ! CFL speed limit for a berg + + cn_dir = './' ! root directory for the calving 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_icb = 'calving' , -1. ,'calvingmask', .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) +!----------------------------------------------------------------------- + ! ! free slip ! partial slip ! no slip ! strong slip + rn_shlat = -9999. ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. + ln_shlat2d = .false. + cn_shlat2d_file = "empty" + cn_shlat2d_var = "empty" +/ +!----------------------------------------------------------------------- +&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 +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .false. ! Activate tides + ln_tide_pot = .false. ! use tidal potential forcing + ln_scal_load = .false. ! Use scalar approximation for + rn_scal_load = 0.094 ! load potential + ln_read_load = .false. ! Or read load potential from file + cn_tide_load = 'tide_LOAD_grid_T.nc' ! filename for load potential + ! + ln_tide_ramp = .false. ! Use linear ramp for tides at startup + rdttideramp = 0. ! ramp duration in days + clname(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .false. ! Use unstructured open boundaries + nb_bdy = 0 ! number of open boundary sets + ln_coords_file = .true. ! =T : read bdy coordinates from file + cn_coords_file = 'coordinates.bdy.nc' ! bdy coordinates files + ln_mask_file = .false. ! =T : read mask from file + cn_mask_file = '' ! name of mask file (if ln_mask_file=.TRUE.) + cn_dyn2d = 'none' ! + nn_dyn2d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! ! = 2, use tidal harmonic forcing data from files + ! ! = 3, use external data AND tidal harmonic forcing + cn_dyn3d = 'none' ! + nn_dyn3d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_tra = 'none' ! + nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_ice = 'none' ! + nn_ice_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! + ln_tra_dmp =.false. ! open boudaries conditions for tracers + ln_dyn3d_dmp =.false. ! open boundary condition for baroclinic velocities + rn_time_dmp = 1. ! Damping time scale in days + rn_time_dmp_out = 1. ! Outflow damping time scale + nn_rimwidth = 1 ! width of the relaxation zone + ln_vol = .false. ! total volume correction (see nn_volctl parameter) + nn_volctl = 1 ! = 0, the total water flux across open boundaries is zero +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data (see nam_bdy) +!----------------------------------------------------------------------- + ln_zinterp = .false. ! T if a vertical interpolation is required. Variables gdep[tuv] and e3[tuv] must exist in the file + ! ! automatically defined to T if the number of vertical levels in bdy dta /= jpk + ln_full_vel = .false. ! T if [uv]3d are "full" velocities and not only its baroclinic components + ! ! in this case, baroclinic and barotropic velocities will be recomputed -> [uv]2d not needed + ! + cn_dir = 'bdydta/' ! root directory for the BDY 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 ! + bn_ssh = 'amm12_bdyT_u2d' , 24. , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24. , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24. , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24. , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24. , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24. , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24. , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' , 24. , 'siconc' , .true. , .false., 'daily' , '' , '' , '' + bn_h_i = 'amm12_bdyT_ice' , 24. , 'sithic' , .true. , .false., 'daily' , '' , '' , '' + bn_h_s = 'amm12_bdyT_ice' , 24. , 'snthic' , .true. , .false., 'daily' , '' , '' , '' + bn_t_i = 'NOT USED' , 24. , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24. , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24. , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24. , 'sisalt' , .true. , .false., 'daily' , '' , '' , '' + ! melt ponds (be careful, bn_aip is the pond concentration (not fraction), so it differs from rn_iceapnd) + bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! -- salinity -- + rn_ice_age = 30. ! -- age -- + rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i -- + rn_ice_hpnd = 0.05 ! -- pond depth -- + rn_ice_hlid = 0.0 ! -- pond lid depth -- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries (default: OFF) +!----------------------------------------------------------------------- + filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. ! + ln_bdytide_conj = .false. ! +/ + +!!====================================================================== +!! *** 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_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot + ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) + ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ! + ln_drgimp = .true. ! implicit top/bottom friction flag + ln_drgice_imp = .false. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 1 constant flux + ! ! = 2 read variable flux [mW/m2] + rn_geoflx_cst = 86.4e-3 ! Constant value of geothermal heat 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 = .false. ! 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_teos10 = .true. ! = Use TEOS-10 + ln_eos80 = .false. ! = Use EOS80 + ln_seos = .false. ! = Use S-EOS (simplified Eq.) + ! + ! ! S-EOS coefficients (ln_seos=T): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 1.6550e-1 ! thermal expension coefficient + rn_b0 = 7.6554e-1 ! saline expension coefficient + rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 7.4914e-4 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 1.4970e-4 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.1090e-5 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 2.4341e-3 ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_OFF = .false. ! No tracer advection + ln_traadv_cen = .false. ! 2nd order centered scheme + nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_traadv_fct = .false. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + ln_traadv_mus = .false. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths + ln_traadv_ubs = .false. ! UBS scheme + nn_ubs_v = 2 ! =2 , vertical 2nd order FCT / COMPACT 4th order + ln_traadv_qck = .false. ! QUICKEST scheme +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .false. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator + ! + ! ! Direction of action: + ln_traldf_lev = .false. ! iso-level + ln_traldf_hor = .false. ! horizontal (geopotential) + ln_traldf_iso = .false. ! iso-neutral (standard operator) + ln_traldf_triad = .false. ! iso-neutral (triad operator) + ! + ! ! iso-neutral options: + ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators) + rn_slpmax = 0.01 ! slope limit (both operators) + ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only) + rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only) + ln_botmix_triad = .false. ! lateral mixing on bottom (triad only) + ! + ! ! Coefficients: + nn_aht_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing) + ! ! time invariant coefficients: aht0 = 1/2 Ud*Ld (lap case) + ! ! or = 1/12 Ud*Ld^3 (blp case) + rn_Ud = 0.01 ! 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 = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation + rn_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) + nn_mle = 1 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + rn_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) + nn_mld_uv = 0 ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + nn_conv = 0 ! =1 no MLE in case of convection ; =0 always MLE + rn_rho_c_mle = 0.01 ! delta rho criterion used to calculate MLD for FK +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_induced_velocity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.02 ! 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 =.false. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .false. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column + ! ! =1 no damping in the mixing layer (kz criteria) + ! ! =2 no damping in the mixed layer (rho crieria) + cn_resto = 'resto.nc' ! Name of file containing restoration coeff. field (use dmp_tools to create this) +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! z-star vertical coordinate + ln_vvl_ztilde = .false. ! z-tilde vertical coordinate: only high frequency variations + ln_vvl_layer = .false. ! full layer vertical coordinate + ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar + ln_vvl_zstar_at_eqtor = .false. ! ztilde near the equator + rn_ahe3 = 0.0 ! thickness diffusion coefficient + rn_rst_e3t = 30.0 ! ztilde to zstar restoration timescale [days] + rn_lf_cutoff = 5.0 ! cutoff frequency for low-pass filter [days] + rn_zdef_max = 0.9 ! maximum fractional e3t deformation + ln_vvl_dbg = .true. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .false. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .false. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! energy conserving scheme + ln_dynvor_ens = .false. ! enstrophy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_enT = .false. ! energy conserving scheme (T-point) + ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) + ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE + ! ! (f-point vorticity schemes only) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .false. ! z-coordinate - full steps + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .false. ! s-coordinate (standard jacobian formulation) + ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf + ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) + ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. ! explicit free surface + ln_dynspg_ts = .false. ! split-explicit free surface + ln_bt_fw = .true. ! Forward integration of barotropic Eqs. + ln_bt_av = .true. ! Time filtering of barotropic variables + nn_bt_flt = 1 ! Time filter choice = 0 None + ! ! = 1 Boxcar over nn_baro sub-steps + ! ! = 2 Boxcar over 2*nn_baro " " + ln_bt_auto = .true. ! Number of sub-step defined from: + rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds + rn_bt_alpha = 0. ! Temporal diffusion parameter (if ln_bt_av=F) +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) + ln_dynldf_lap = .false. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coefficient : + ! ! =-30 read in eddy_viscosity_3D.nc file + ! ! =-20 read in eddy_viscosity_2D.nc file + ! ! = 0 constant + ! ! = 10 F(k)=c1d + ! ! = 20 F(i,j)=F(grid spacing)=c2d + ! ! = 30 F(i,j,k)=c2d*c1d + ! ! = 31 F(i,j,k)=F(grid spacing and local velocity) + ! ! = 32 F(i,j,k)=F(local gridscale and deformation rate) + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.1 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) + ! ! Smagorinsky settings (nn_ahm_ijk_t= 32) : + rn_csmc = 3.5 ! Smagorinsky constant of proportionality + rn_minfac = 1.0 ! multiplier of theorectical lower limit + rn_maxfac = 1.0 ! multiplier of theorectical upper limit + ! ! iso-neutral laplacian operator (ln_dynldf_iso=T) : + rn_ahm_b = 0.0 ! background eddy viscosity [m2/s] +/ +!----------------------------------------------------------------------- +&namdta_dyn ! offline ocean input files (OFF_SRC only) +!----------------------------------------------------------------------- + ln_dynrnf = .false. ! runoffs option enabled (T) or not (F) + ln_dynrnf_depth = .false. ! runoffs is spread in vertical (T) or not (F) +! fwbcorr = 3.786e-06 ! annual global mean of empmr for ssh correction + + cn_dir = './' ! root directory for the ocean 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 = 'dyna_grid_T' , 120. , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120. , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120. , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120. , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120. , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120. , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120. , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120. , 'sobblcoy' , .true. , .true. , 'yearly' , '' , '' , '' +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! adaptive-implicit vertical advection + ln_zad_Aimp = .false. ! Courant number dependent scheme (Shchepetkin 2015) + ! + ! ! type of vertical closure (required) + ln_zdfcst = .false. ! constant mixing + ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) + ln_zdftke = .false. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfgls = .false. ! Generic Length Scale closure (T => fill namzdf_gls) + ln_zdfosm = .false. ! OSMOSIS BL closure (T => fill namzdf_osm) + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + nn_evdm = 0 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! mixing coefficient [m2/s] + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + nn_npc = 1 ! frequency of application of npc + nn_npcp = 365 ! npc control print frequency + ! + ln_zdfddm = .false. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ! + ! ! gravity wave-driven vertical mixing + ln_zdfiwm = .false. ! internal wave-induced mixing (T => fill namzdf_iwm) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 100.e-4 ! maximum value of the vertical viscosity + rn_alp = 5. ! coefficient of the parameterization + nn_ric = 2 ! coefficient of the parameterization + ln_mldw = .false. ! enhanced mixing in the Ekman layer + rn_ekmfc = 0.7 ! Factor in the Ekman depth Equation + rn_mldmin = 1.0 ! minimum allowable mixed-layer depth estimate (m) + rn_mldmax = 1000.0 ! maximum allowable mixed-layer depth estimate (m) + rn_wtmix = 10.0 ! vertical eddy viscosity coeff [m2/s] in the mixed-layer + rn_wvmix = 10.0 ! vertical eddy diffusion coeff [m2/s] in the mixed-layer +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + rn_ediff = 0.1 ! coef. for vertical eddy coef. (avt=rn_ediff*mxl*sqrt(e) ) + rn_ediss = 0.7 ! coef. of the Kolmogoroff dissipation + rn_ebb = 67.83 ! coef. of the surface input of tke (=67.83 suggested when ln_mxl0=T) + rn_emin = 1.e-6 ! minimum value of tke [m2/s2] + rn_emin0 = 1.e-4 ! surface minimum value of tke [m2/s2] + rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it) + nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm) + 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 + ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) + nn_mxlice = 2 ! type of scaling under sea-ice + ! = 0 no scaling under sea-ice + ! = 1 scaling with constant sea-ice thickness + ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) + ! = 3 scaling with maximum sea-ice thickness + rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) + rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value + ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002) + rn_lc = 0.15 ! coef. associated to Langmuir cells + 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) + rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) + nn_htau = 1 ! type of exponential decrease of tke penetration below the ML + ! = 0 constant 10 m length scale + ! = 1 0.5m at the equator to 30m poleward of 40 degrees + nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice + ! ! = 0 no impact of ice cover on langmuir & surface wave breaking + ! ! = 1 weigthed by 1-TANH(10*fr_i) + ! ! = 2 weighted by 1-fr_i + ! ! = 3 weighted by 1-MIN(1,4*fr_i) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1.e-7 ! minimum value of e [m2/s2] + rn_epsmin = 1.e-12 ! minimum value of eps [m2/s3] + ln_length_lim = .true. ! limit on the dissipation rate under stable stratification (Galperin et al., 1988) + rn_clim_galp = 0.267 ! galperin limit + ln_sigpsi = .true. ! Activate or not Burchard 2001 mods on psi schmidt number in the wb case + rn_crban = 100. ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000. ! Charnock constant for wb induced roughness length + rn_hsro = 0.02 ! Minimum surface roughness + rn_hsri = 0.03 ! Ice-ocean roughness + rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1) + nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) + ! ! = 3 requires ln_wave=T + nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice + ! ! = 0 no impact of ice cover + ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i) + ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i + ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i) + nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum) + nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum) + nn_stab_func = 2 ! stability function (0=Galp, 1= KC94, 2=CanutoA, 3=CanutoB) + nn_clos = 1 ! predefined closure type (0=MY82, 1=k-eps, 2=k-w, 3=Gen) +/ +!----------------------------------------------------------------------- +&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) +!----------------------------------------------------------------------- + ln_use_osm_la = .false. ! Use namelist rn_osm_la + rn_osm_la = 0.3 ! Turbulent Langmuir number + rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) + nn_ave = 0 ! choice of horizontal averaging on avt, avmu, avmv + ln_dia_osm = .true. ! output OSMOSIS-OBL variables + rn_osm_hbl0 = 10. ! initial hbl value + ln_kpprimix = .true. ! Use KPP-style Ri# mixing below BL + rn_riinfty = 0.7 ! Highest local Ri_g permitting shear instability + rn_difri = 0.005 ! max Ri# diffusivity at Ri_g = 0 (m^2/s) + ln_convmix = .true. ! Use convective instability mixing below BL + rn_difconv = 1. ! diffusivity when unstable below BL (m2/s) + nn_osm_wave = 0 ! Method used to calculate Stokes drift + ! ! = 2: Use ECMWF wave fields + ! ! = 1: Pierson Moskowitz wave spectrum + ! ! = 0: Constant La# = 0.3 +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) + ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency + ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) +/ + +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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_diaharm Harmonic analysis of tidal constituents (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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtrd ! trend diagnostics (default: OFF) +!----------------------------------------------------------------------- + ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE + ln_dyn_trd = .false. ! (T) 3D momentum trend output + ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet) + ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet) + ln_KE_trd = .false. ! (T) 3D Kinetic Energy trends + ln_PE_trd = .false. ! (T) 3D Potential Energy trends + ln_tra_trd = .false. ! (T) 3D tracer trend output + ln_tra_mxl = .false. ! (T) 2D tracer trends averaged over the mixed layer (not coded yet) + nn_trd = 365 ! print frequency (ln_glo_trd=T) (unit=time step) +/ +!!gm nn_ctls = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) +!!gm cn_trdrst_in = "restart_mld" ! suffix of ocean restart name (input) +!!gm cn_trdrst_out = "restart_mld" ! suffix of ocean restart name (output) +!!gm ln_trdmld_restart = .false. ! restart for ML diagnostics +!!gm ln_trdmld_instant = .false. ! flag to diagnose trends of instantantaneous or mean ML T/S +!!gm +!----------------------------------------------------------------------- +&namptr ! Poleward Transport Diagnostic (default: OFF) +!----------------------------------------------------------------------- + ln_diaptr = .false. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .false. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .false. ! output the heat and salt budgets (T) or not (F) +/ +!----------------------------------------------------------------------- +&namdiu ! Cool skin and warm layer models (default: OFF) +!----------------------------------------------------------------------- + ln_diurnal = .false. ! + ln_diurnal_only = .false. ! +/ +!----------------------------------------------------------------------- +&namflo ! float parameters (default: OFF) +!----------------------------------------------------------------------- + ln_floats = .false. ! activate floats or not + jpnfl = 1 ! total number of floats during the run + jpnnewflo = 0 ! number of floats for the restart + ln_rstflo = .false. ! float restart (T) or not (F) + nn_writefl = 75 ! frequency of writing in float output file + nn_stockfl = 5475 ! frequency of creation of the float restart file + ln_argo = .false. ! Argo type floats (stay at the surface each 10 days) + ln_flork4 = .false. ! trajectories computed with a 4th order Runge-Kutta (T) + ! ! or computed with Blanke' scheme (F) + ln_ariane = .true. ! Input with Ariane tool convention(T) + ln_flo_ascii= .true. ! Output with Ariane tool netcdf convention(F) or ascii file (T) +/ +!----------------------------------------------------------------------- +&nam_diaharm ! Harmonic analysis of tidal constituents (default: OFF) +!----------------------------------------------------------------------- + ln_diaharm = .false. ! Choose tidal harmonic output or not + nit000_han = 1 ! First time step used for harmonic analysis + nitend_han = 75 ! Last time step used for harmonic analysis + nstep_han = 15 ! Time step frequency for harmonic analysis + tname(1) = 'M2' ! Name of tidal constituents + tname(2) = 'K1' ! --- +/ +!----------------------------------------------------------------------- +&nam_diadct ! transports through some sections (default: OFF) +!----------------------------------------------------------------------- + ln_diadct = .false. ! Calculate transport thru sections or not + nn_dct = 15 ! time step frequency for transports computing + nn_dctwri = 15 ! time step frequency for transports writing + nn_secdebug = 112 ! 0 : no section to debug + ! ! -1 : debug all section + ! ! 0 < n : debug section number n +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default: OFF) +!----------------------------------------------------------------------- + ln_dia25h = .false. ! Choose 25h mean output or not +/ +!----------------------------------------------------------------------- +&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") +!----------------------------------------------------------------------- + nn_nchunks_i = 4 ! number of chunks in i-dimension + nn_nchunks_j = 4 ! number of chunks in j-dimension + nn_nchunks_k = 31 ! number of chunks in k-dimension + ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which + ! ! is optimal for postprocessing which works exclusively with horizontal slabs + ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression + ! ! (F) ignore chunking information and produce netcdf3-compatible files +/ + +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!----------------------------------------------------------------------- +&namobs ! observation usage switch (default: OFF) +!----------------------------------------------------------------------- + ln_diaobs = .false. ! Logical switch for the observation operator + ! + ln_t3d = .false. ! Logical switch for T profile observations + ln_s3d = .false. ! Logical switch for S profile observations + ln_sla = .false. ! Logical switch for SLA observations + ln_sst = .false. ! Logical switch for SST observations + ln_sss = .false. ! Logical swithc for SSS observations + ln_sic = .false. ! Logical switch for Sea Ice observations + ln_vel3d = .false. ! Logical switch for velocity observations + ln_altbias = .false. ! Logical switch for altimeter bias correction + ln_sstbias = .false. ! Logical switch for SST bias correction + ln_nea = .false. ! Logical switch for rejection of observations near land + ln_grid_global = .true. ! Logical switch for global distribution of observations + ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table + ln_ignmis = .true. ! Logical switch for ignoring missing files + ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there + ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs + ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. + ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres + ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres + ln_sss_fp_indegs = .true. ! Logical for SSS: T=> averaging footprint is in degrees, F=> in metres + ln_sic_fp_indegs = .true. ! Logical for SIC: T=> averaging footprint is in degrees, F=> in metres +! All of the *files* variables below are arrays. Use namelist_cfg to add more files + cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names + cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names + cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names + cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names + cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names + cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names + cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name + cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file name + cn_gridsearchfile ='gridsearch.nc' ! Grid search file name + rn_gridsearchres = 0.5 ! Grid search resolution + rn_mdtcorr = 1.61 ! MDT correction + rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction + rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) + nn_1dint = 0 ! Type of vertical interpolation method + nn_2dint = 0 ! Default horizontal interpolation method + nn_2dint_sla = 0 ! Horizontal interpolation method for SLA + nn_2dint_sst = 0 ! Horizontal interpolation method for SST + nn_2dint_sss = 0 ! Horizontal interpolation method for SSS + nn_2dint_sic = 0 ! Horizontal interpolation method for SIC + nn_msshc = 0 ! MSSH correction scheme + nn_profdavtypes = -1 ! Profile daily average types - array +/ +!----------------------------------------------------------------------- +&nam_asminc ! assimilation increments ('key_asminc') +!----------------------------------------------------------------------- + ln_bkgwri = .false. ! Logical switch for writing out background state + ln_trainc = .false. ! Logical switch for applying tracer increments + ln_dyninc = .false. ! Logical switch for applying velocity increments + ln_sshinc = .false. ! Logical switch for applying SSH increments + ln_asmdin = .false. ! Logical switch for Direct Initialization (DI) + ln_asmiau = .false. ! Logical switch for Incremental Analysis Updating (IAU) + nitbkg = 0 ! Timestep of background in [0,nitend-nit000-1] + nitdin = 0 ! Timestep of background for DI in [0,nitend-nit000-1] + nitiaustr = 1 ! Timestep of start of IAU interval in [0,nitend-nit000-1] + nitiaufin = 15 ! Timestep of end of IAU interval in [0,nitend-nit000-1] + niaufn = 0 ! Type of IAU weighting function + ln_salfix = .false. ! Logical switch for ensuring that the sa > salfixmin + salfixmin = -9999 ! Minimum salinity after applying the increments + nn_divdmp = 0 ! Number of iterations of divergence damping operator +/ + +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_listonly = .false. ! do nothing else than listing the best domain decompositions (with land domains suppression) + ! ! if T: the largest number of cores tested is defined by max(mppsize, jpni*jpnj) + ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold + jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T + sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following + sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings. + sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure + sn_cfctl%l_oceout = .FALSE. ! that all areas report. + sn_cfctl%l_layout = .FALSE. ! + sn_cfctl%l_mppout = .FALSE. ! + sn_cfctl%l_mpptop = .FALSE. ! + sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0] + sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000] + sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1] + sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info + nn_print = 0 ! level of print (0 no extra print) + nn_ictls = 0 ! start i indice of control sum (use to compare mono versus + nn_ictle = 0 ! end i indice of control sum multi processor runs + nn_jctls = 0 ! start j indice of control over a subdomain) + nn_jctle = 0 ! end j indice of control + nn_isplt = 1 ! number of processors in i-direction + nn_jsplt = 1 ! number of processors in j-direction + ln_timing = .false. ! timing by routine write out in timing.output file + ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- + ln_sto_eos = .false. ! stochastic equation of state + nn_sto_eos = 1 ! number of independent random walks + rn_eos_stdxy = 1.4 ! random walk horz. standard deviation (in grid points) + rn_eos_stdz = 0.7 ! random walk vert. standard deviation (in grid points) + rn_eos_tcor = 1440. ! random walk time correlation (in timesteps) + nn_eos_ord = 1 ! order of autoregressive processes + nn_eos_flt = 0 ! passes of Laplacian filter + rn_eos_lim = 2.0 ! limitation factor (default = 3.0) + ln_rststo = .false. ! start from mean parameter (F) or from restart file (T) + ln_rstseed = .true. ! read seed of RNG from restart file + cn_storst_in = "restart_sto" ! suffix of stochastic parameter restart file (input) + cn_storst_out = "restart_sto" ! suffix of stochastic parameter restart file (output) +/ diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/nemo b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/nemo new file mode 120000 index 0000000..170c312 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/nemo @@ -0,0 +1 @@ +/work/n01/n01/jelt/AMM7_SURGE/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/BLD/bin/nemo.exe \ No newline at end of file diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/runscript.slurm b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/runscript.slurm new file mode 100644 index 0000000..b3893e5 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/runscript.slurm @@ -0,0 +1,46 @@ +#!/bin/bash +#SBATCH --job-name=SRG_tide +#SBATCH --time=00:30:00 +#SBATCH --nodes=2 +#SBATCH --ntasks-per-core=1 +#SBATCH --account=n01-class +#SBATCH --partition=standard +#SBATCH --qos=standard +#SBATCH -o %A_%a.out +#SBATCH -e %A_%a.err + +start=`date +%s` + +# Created by: mkslurm_hetjob -S 4 -s 16 -m 2 -C 96 -g 2 -N 128 -t 00:10:00 -a n01 -j nemo_test -v False +#module swap PrgEnv-cray/8.0.0 PrgEnv-gnu/8.1.0 +#module swap craype-network-ofi craype-network-ucx +#module swap cray-mpich cray-mpich-ucx +#module load cray-hdf5-parallel/1.12.0.7 +#module load cray-netcdf-hdf5parallel/4.7.4.7 +#module load libfabric +#module list +export OMP_NUM_THREADS=1 + +cat > myscript_wrapper.sh << EOFB +#!/bin/ksh +# +set -A map ./xios_server.exe ./nemo +exec_map=( 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) +# +exec \${map[\${exec_map[\$SLURM_PROCID]}]} +## +EOFB +chmod u+x ./myscript_wrapper.sh + +srun --mem-bind=local \ +--ntasks=100 --ntasks-per-node=50 --cpu-bind=v,mask_cpu:0x1,0x10000,0x100000000,0x400000000,0x1000000000,0x4000000000,0x10000000000,0x40000000000,0x100000000000,0x400000000000,0x1000000000000,0x4000000000000,0x10000000000000,0x40000000000000,0x100000000000000,0x400000000000000,0x1000000000000000,0x4000000000000000,0x10000000000000000,0x40000000000000000,0x100000000000000000,0x400000000000000000,0x1000000000000000000,0x4000000000000000000,0x10000000000000000000,0x40000000000000000000,0x100000000000000000000,0x400000000000000000000,0x1000000000000000000000,0x4000000000000000000000,0x10000000000000000000000,0x40000000000000000000000,0x100000000000000000000000,0x400000000000000000000000,0x1000000000000000000000000,0x4000000000000000000000000,0x10000000000000000000000000,0x40000000000000000000000000,0x100000000000000000000000000,0x400000000000000000000000000,0x1000000000000000000000000000,0x4000000000000000000000000000,0x10000000000000000000000000000,0x40000000000000000000000000000,0x100000000000000000000000000000,0x400000000000000000000000000000,0x1000000000000000000000000000000,0x4000000000000000000000000000000,0x10000000000000000000000000000000,0x40000000000000000000000000000000 ./myscript_wrapper.sh + + +end=`date +%s` +runtime=$((end-start)) +hours=$((runtime / 3600)) +minutes=$(( (runtime % 3600) / 60 )) +seconds=$(( (runtime % 3600) % 60 )) +echo "Runtime: $hours:$minutes:$seconds (hh:mm:ss)" +wait +exit diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/xios_server.exe b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/xios_server.exe new file mode 120000 index 0000000..b4fca65 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO/xios_server.exe @@ -0,0 +1 @@ +/work/n01/shared/nemo/XIOS2_Cray/bin/xios_server.exe \ No newline at end of file diff --git a/MY_SRC/usrdef_istate.F90 b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC/usrdef_istate.F90 similarity index 100% rename from MY_SRC/usrdef_istate.F90 rename to NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC/usrdef_istate.F90 diff --git a/MY_SRC/usrdef_sbc.F90 b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC/usrdef_sbc.F90 similarity index 94% rename from MY_SRC/usrdef_sbc.F90 rename to NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC/usrdef_sbc.F90 index 9c51862..0965133 100644 --- a/MY_SRC/usrdef_sbc.F90 +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC/usrdef_sbc.F90 @@ -24,9 +24,9 @@ MODULE usrdef_sbc ! USE in_out_manager ! I/O manager USE iom - USE lib_mpp ! distribued memory computing library USE lbclnk ! ocean lateral boundary conditions (or mpp link) - USE wrk_nemo ! work arrays + USE lib_mpp ! distribued memory computing library + !USE wrk_nemo ! work arrays USE timing ! Timing USE prtctl ! Print control @@ -95,7 +95,7 @@ SUBROUTINE usrdef_sbc_oce( kt ) REWIND( numnam_cfg ) ! Namelist namsbc_usr in configuration namelist READ ( numnam_cfg, namsbc_usr, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_surge in configuration namelist', lwp ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_surge in configuration namelist' ) IF(lwm) WRITE( numond, namsbc_usr ) @@ -174,14 +174,15 @@ SUBROUTINE surge_oce( kt, sf, pu, pv, rn_charn_const ) REAL(wp) :: zztmp ! local variable REAL(wp) :: z_z0, z_Cd1 ! local variable REAL(wp) :: zi ! local variable - REAL(wp), DIMENSION(:,:), POINTER :: zwnd_i, zwnd_j ! wind speed components at T-point - REAL(wp), DIMENSION(:,:), POINTER :: Cd ! transfer coefficient for momentum (tau) + REAL(wp), ALLOCATABLE, DIMENSION(:,:):: zwnd_i, zwnd_j ! wind speed components at T-point + REAL(wp), ALLOCATABLE, DIMENSION(:,:):: Cd ! transfer coefficient for momentum (tau) !!--------------------------------------------------------------------- ! - IF( nn_timing == 1 ) CALL timing_start('surge_oce') + IF( ln_timing ) CALL timing_start('surge_oce') ! - CALL wrk_alloc( jpi,jpj, zwnd_i, zwnd_j ) - CALL wrk_alloc( jpi,jpj, Cd ) + ALLOCATE( zwnd_i(jpi,jpj) ) + ALLOCATE( zwnd_j(jpi,jpj) ) + ALLOCATE( Cd(jpi,jpj) ) ! ! ----------------------------------------------------------------------------- ! ! 0 Wind components and module at T-point relative to the moving ocean ! @@ -199,8 +200,8 @@ SUBROUTINE surge_oce( kt, sf, pu, pv, rn_charn_const ) zwnd_i(:,:) = uwnd(:,:) zwnd_j(:,:) = vwnd(:,:) - CALL lbc_lnk( zwnd_i(:,:) , 'T', -1. ) - CALL lbc_lnk( zwnd_j(:,:) , 'T', -1. ) + CALL lbc_lnk( 'surge_oce', zwnd_i(:,:) , 'T', -1. ) + CALL lbc_lnk( 'surge_oce', zwnd_j(:,:) , 'T', -1. ) ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) wndm(:,:) = SQRT( zwnd_i(:,:) * zwnd_i(:,:) & & + zwnd_j(:,:) * zwnd_j(:,:) ) * tmask(:,:,1) @@ -254,8 +255,8 @@ SUBROUTINE surge_oce( kt, sf, pu, pv, rn_charn_const ) & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) END DO END DO - CALL lbc_lnk( utau(:,:), 'U', -1. ) - CALL lbc_lnk( vtau(:,:), 'V', -1. ) + CALL lbc_lnk( 'surge_oce', utau(:,:), 'U', -1. ) + CALL lbc_lnk( 'surge_oce', vtau(:,:), 'V', -1. ) IF(ln_ctl) THEN @@ -283,10 +284,11 @@ SUBROUTINE surge_oce( kt, sf, pu, pv, rn_charn_const ) & tab2d_2=vtau , clinfo2= ' vtau : ' , mask2=vmask ) ENDIF ! - CALL wrk_dealloc( jpi,jpj, zwnd_i, zwnd_j ) - CALL wrk_dealloc( jpi,jpj, Cd ) +! DEALLOCATE( zwnd_i(jpi,jpj) ) +! DEALLOCATE( zwnd_j(jpi,jpj) ) +! DEALLOCATE( Cd(jpi,jpj) ) ! - IF( nn_timing == 1 ) CALL timing_stop('surge_oce') + IF( ln_timing ) CALL timing_stop('surge_oce') ! END SUBROUTINE surge_oce diff --git a/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/cpp_AMM7_SURGE.fcm b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/cpp_AMM7_SURGE.fcm new file mode 100644 index 0000000..29ac2dd --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/cpp_AMM7_SURGE.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_diainstant key_mpp_mpi key_iomput key_nosignedzero diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/README.namelists b/NEMO_4.0.4_surge/cfgs/SHARED/README.namelists new file mode 100644 index 0000000..b4799e6 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/README.namelists @@ -0,0 +1,109 @@ +Simple style rules for namelists +-------------------------------- + +NEMO reference namelists should adhere to the following simple style rules: + +1. Comments outside a namelist block start with !! in column 1 +2. Each namelist block starts with 3 lines of the form: + +!----------------------------------------------------------------------- +&namblockname ! short description of block +!----------------------------------------------------------------------- + + with all ! and & 's starting in column 1 +3. The closing / for each namelist block is in column 1 +4. Comments within namelist blocks never start with !- . Use ! followed + by space or != etc. + +These conventions make it possible to construct empty configuration namelists. +For example, a namelist_cfg template can be produced from namelist_ref with +the following grep command; e.g.: + +grep -E '^!-|^&|^/' namelist_ref > namelist_cfg.template + +head namelist_cfg.template + +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration +!----------------------------------------------------------------------- +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- +/ +. +. + +If all configuration namelists are produced and maintained using this +strategy then standard, side-by-side comaparators, such as vimdiff or xxdiff, +can be used to compare and transfer lines from the reference namelist to a +configuration namelist when setting up a new configuration. + +Tips and tricks +--------------- + +1. The following bash function is useful when checking which namelist blocks +are in active use in a configuration namelist: + + function list_used_nl(){ grep -n -E '^&|^/' "$1" | sed -e 's/:/ /' \ + | awk ' BEGIN { x = 0 } \ + {if ( NR % 2 == 0 && $1 - x > 2 ) printf("%3d %s\n", $1 - x , n) ; \ + else x = $1; n = $2}' \ + | sort -k 2;} + +which (assuming the namelist adheres to the conventions) will list the number +of entries in each non-empty namelist block. The list is sorted on the block +name to ease comparisons. For example: + + list_used_nl ORCA2_LIM3_PISCES/EXP00/namelist_cfg + + 1 &nambbc + 5 &nambbl + 30 &namberg + 10 &namcfg + 4 &namctl + 3 &namdom + 1 &namdrg + 5 &namdyn_adv + 1 &namdyn_hpg + 22 &namdyn_ldf + 1 &namdyn_spg + 5 &namdyn_vor + 3 &nameos + 1 &namhsb + 4 &namrun + 1 &namsbc + 1 &namsbc_blk + 3 &namtra_adv + 28 &namtra_ldf + 10 &namtra_ldfeiv + 25 &namzdf + 3 &namzdf_iwm + +2. vimdiff can give garish colours in some terminals. Usually this is because +vim assumes, incorrectly, that the terminal only supports 8 colours. Try forcing +256 colours with: + + :set t_Co=256 + +to produce more pastel shades (add this to ~/.vimrc if successful). + +3. Switching between vsplit panes in vim is a multi-key sequence. The tool is +much easier to use if the sequence is mapped to a spare key. Here I use the +§ and ± key on my Mac keyboard (add to ~/.vimrc): + + map § ^Wl + map ± ^Wh + +4. With easy switching between panes, constructing namelists in vimdiff just +requires the following commands in addition to normal editing: + + ]c - Go to next block of the diff + dp - Push version of the block under cursor into the other pane + do - Pull version of the block under cursor from the other pane + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/README.rst b/NEMO_4.0.4_surge/cfgs/SHARED/README.rst new file mode 100644 index 0000000..2adfd0a --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/README.rst @@ -0,0 +1,119 @@ +*********** +Diagnostics +*********** + +.. todo:: + + + +.. contents:: + :local: + +Output of diagnostics in NEMO is usually done using XIOS. +This is an efficient way of writing diagnostics because +the time averaging, file writing and even some simple arithmetic or regridding is carried out in +parallel to the NEMO model run. +This page gives a basic introduction to using XIOS with NEMO. +Much more information is available from the :xios:`XIOS homepage<>` above and from the NEMO manual. + +Use of XIOS for diagnostics is activated using the pre-compiler key ``key_iomput``. + +Extracting and installing XIOS +============================== + +1. Install the NetCDF4 library. + If you want to use single file output you will need to compile the HDF & NetCDF libraries to + allow parallel IO. +2. Download the version of XIOS that you wish to use. + The recommended version is now XIOS 2.5: + + .. code-block:: console + + $ svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5 + +and follow the instructions in :xios:`XIOS documentation ` to compile it. +If you find problems at this stage, support can be found by subscribing to +the :xios:`XIOS mailing list <../mailman/listinfo.cgi/xios-users>` and sending a mail message to it. + +XIOS Configuration files +------------------------ + +XIOS is controlled using XML input files that should be copied to +your model run directory before running the model. +Examples of these files can be found in the reference configurations (:file:`./cfgs`). +The XIOS executable expects to find a file called :file:`iodef.xml` in the model run directory. +In NEMO we have made the decision to use include statements in the :file:`iodef.xml` file to include: + +- :file:`field_def_nemo-oce.xml` (for physics), +- :file:`field_def_nemo-ice.xml` (for ice), +- :file:`field_def_nemo-pisces.xml` (for biogeochemistry) and +- :file:`domain_def.xml` from the :file:`./cfgs/SHARED` directory. + +Most users will not need to modify :file:`domain_def.xml` or :file:`field_def_nemo-???.xml` unless +they want to add new diagnostics to the NEMO code. +The definition of the output files is organized into separate :file:`file_definition.xml` files which +are included in the :file:`iodef.xml` file. + +Modes +===== + +Detached Mode +------------- + +In detached mode the XIOS executable is executed on separate cores from the NEMO model. +This is the recommended method for using XIOS for realistic model runs. +To use this mode set ``using_server`` to ``true`` at the bottom of the :file:`iodef.xml` file: + +.. code-block:: xml + + true + +Make sure there is a copy (or link to) your XIOS executable in the working directory and +in your job submission script allocate processors to XIOS. + +Attached Mode +------------- + +In attached mode XIOS runs on each of the cores used by NEMO. +This method is less efficient than the detached mode but can be more convenient for testing or +with small configurations. +To activate this mode simply set ``using_server`` to false in the :file:`iodef.xml` file + +.. code-block:: xml + + false + +and don't allocate any cores to XIOS. + +.. note:: + + Due to the different domain decompositions between XIOS and NEMO, + if the total number of cores is larger than the number of grid points in the ``j`` direction then + the model run will fail. + +Adding new diagnostics +====================== + +If you want to add a NEMO diagnostic to the NEMO code you will need to do the following: + +1. Add any necessary code to calculate you new diagnostic in NEMO +2. Send the field to XIOS using ``CALL iom_put( 'field_id', variable )`` where + ``field_id`` is a unique id for your new diagnostics and + variable is the fortran variable containing the data. + This should be called at every model timestep regardless of how often you want to output the field. + No time averaging should be done in the model code. +3. If it is computationally expensive to calculate your new diagnostic + you should also use "iom_use" to determine if it is requested in the current model run. + For example, + + .. code-block:: fortran + + IF iom_use('field_id') THEN + !Some expensive computation + !... + !... + iom_put('field_id', variable) + ENDIF + +4. Add a variable definition to the :file:`field_def_nemo-???.xml` file. +5. Add the variable to the :file:`iodef.xml` or :file:`file_definition.xml` file. diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/axis_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/SHARED/axis_def_nemo.xml new file mode 100644 index 0000000..a7d66bc --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/axis_def_nemo.xml @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/domain_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/SHARED/domain_def_nemo.xml new file mode 100644 index 0000000..0931e2b --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/domain_def_nemo.xml @@ -0,0 +1,198 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-ice.xml b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-ice.xml new file mode 100644 index 0000000..adab137 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-ice.xml @@ -0,0 +1,618 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + icemass * icemask + $missval * (1.-icemask ) + icethic * icemask05 + $missval * (1.-icemask05) + snwmass * icemask + $missval * (1.-icemask ) + snwthic * icemask05 + $missval * (1.-icemask05) + iceconc * 100. + iceage * icemask15 + $missval * (1.-icemask15) + icesalt * icemask + $missval * (1.-icemask ) + icefrb * icemask + $missval * (1.-icemask ) + + + (icettop+273.15) * icemask + $missval * (1.-icemask) + (icetsni+273.15) * icemask + $missval * (1.-icemask) + (icetbot+273.15) * icemask + $missval * (1.-icemask) + icehc * icemask + $missval * (1.-icemask) + snwhc * icemask + $missval * (1.-icemask) + + + vfxsum * icemask + $missval * (1.-icemask) + vfxice * icemask + $missval * (1.-icemask) + hfxsensib * icemask + $missval * (1.-icemask) + hfxcndtop * icemask + $missval * (1.-icemask) + hfxcndbot * icemask + $missval * (1.-icemask) + sfxice * icemask + $missval * (1.-icemask) + + + + + + + + + + + + + + + + + + + + uice * icemask + $missval * (1.-icemask) + vice * icemask + $missval * (1.-icemask) + icevel * icemask + $missval * (1.-icemask) + utau_ai * icemask + $missval * (1.-icemask) + vtau_ai * icemask + $missval * (1.-icemask) + + + + + + + + + + + + + + + xmtrpice + xmtrpsnw + ymtrpice + ymtrpsnw + + + @xmtrpice + xmtrpice_ave + + @ymtrpice + ymtrpice_ave + + @xmtrpsnw + xmtrpsnw_ave + + @ymtrpsnw + ymtrpsnw_ave + + @xatrp + xatrp_ave + + @yatrp + yatrp_ave + + + + + + + + + + + + + + + + + + + + + + + + + + + iceconc_cat * icemask_cat + $missval * (1.-icemask_cat) + icethic_cat * icemask_cat + $missval * (1.-icemask_cat) + snwthic_cat * icemask_cat + $missval * (1.-icemask_cat) + iceconc_cat*100. * icemask_cat + $missval * (1.-icemask_cat) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-innerttrc.xml b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-innerttrc.xml new file mode 100644 index 0000000..f79115e --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-innerttrc.xml @@ -0,0 +1,59 @@ + + + + + + + + + + + + + + CFC11 * e3t + + + + + + CFC12 * e3t + + + + + + SF6 * e3t + + + + + + RC14 * e3t + + + + + + + + + + + + + + Age * e3t + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-oce.xml b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-oce.xml new file mode 100644 index 0000000..2fc857c --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-oce.xml @@ -0,0 +1,1136 @@ + + + + + + + + + + + + + + + + + + + + + + + toce_pot * e3t + + soce_pra * e3t + + + toce_con * e3t + + soce_abs * e3t + + + + toce_e3t_vsum300/e3t_vsum300 + + + + + + + + + + + + + + + + + sst_pot * sst_pot + + + + + + + + + + + + sss_pra * sss_pra + + + + + + + sst_con * sst_con + + + + + + + + + + + + sss_abs * sss_abs + + + + + + + + + + + + + + + ssh * ssh + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + topthdep - pycndep + + + + + + + + + + + + + sshdyn * sshdyn + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + uoce * e3u + + this * uoce_e3u_vsum + + @uocetr_vsum + + uocetr_vsum_cumul * $rau0 + + + uoce * uoce * e3u + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ustokes * e3u + + + + + + + + + + + + + + + + + + + + + + + + voce * e3v + voce * voce * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + vstokes * e3v + + + + + + + + + + + + + + + + + + + + woce * e3w + + + + + + + + + + avt * e3w + + + avm * e3w + + + + avs * e3w + + + + + avt_evd * e3w + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ut * e3u + + us * e3u + + urhop * e3u + + vt * e3v + + vs * e3v + + vrhop * e3v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @uoce_e3u + + this * e2u + + @voce_e3v + + this * e1v + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + sophtvtr - sophtove + sophtvtr - sopstove + + + + + + + + + + + + + + + + + + + ttrd_atf * e3t + strd_atf * e3t + + ttrd_atf_e3t * 1026.0 * 3991.86795711963 + strd_atf_e3t * 1026.0 * 0.001 + + + + + + + + + + + sqrt( ttrd_xad^2 + ttrd_yad^2 + ttrd_zad^2 ) + sqrt( strd_xad^2 + strd_yad^2 + strd_zad^2 ) + + + + + + + + + + + + + ttrd_ldf + ttrd_zdf - ttrd_zdfp + strd_ldf + strd_zdf - strd_zdfp + + + + + + + + + + + + + + + + + ttrd_xad * e3t + strd_xad * e3t + ttrd_yad * e3t + strd_yad * e3t + ttrd_zad * e3t + strd_zad * e3t + ttrd_ad * e3t + strd_ad * e3t + ttrd_totad * e3t + strd_totad * e3t + ttrd_ldf * e3t + strd_ldf * e3t + ttrd_zdf * e3t + strd_zdf * e3t + ttrd_evd * e3t + strd_evd * e3t + + + ttrd_iso * e3t + strd_iso * e3t + ttrd_zdfp * e3t + strd_zdfp * e3t + + + ttrd_dmp * e3t + strd_dmp * e3t + ttrd_bbl * e3t + strd_bbl * e3t + ttrd_npc * e3t + strd_npc * e3t + ttrd_qns * e3ts + strd_cdt * e3ts + ttrd_qsr * e3t + ttrd_bbc * e3t + + + ttrd_totad_e3t * 1026.0 * 3991.86795711963 + strd_totad_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + ttrd_iso_e3t * 1026.0 * 3991.86795711963 + strd_iso_e3t * 1026.0 * 0.001 + ttrd_zdfp_e3t * 1026.0 * 3991.86795711963 + strd_zdfp_e3t * 1026.0 * 0.001 + ttrd_qns_e3t * 1026.0 * 3991.86795711963 + ttrd_qsr_e3t * 1026.0 * 3991.86795711963 + ttrd_bbl_e3t * 1026.0 * 3991.86795711963 + strd_bbl_e3t * 1026.0 * 0.001 + ttrd_evd_e3t * 1026.0 * 3991.86795711963 + strd_evd_e3t * 1026.0 * 0.001 + + + + + + + + + ttrd_tot * e3t + strd_tot * e3t + + ttrd_tot_e3t * 1026.0 * 3991.86795711963 + strd_tot_e3t * 1026.0 * 0.001 + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-pisces.xml b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-pisces.xml new file mode 100644 index 0000000..a8c6fbb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/field_def_nemo-pisces.xml @@ -0,0 +1,320 @@ + + + + + + + + + + + + + + DIC * e3t + + Alkalini * e3t + + O2 * e3t + + CaCO3 * e3t + + PO4 * e3t + + POC * e3t + + Si * e3t + + PHY * e3t + + ZOO * e3t + + DOC * e3t + + PHY2 * e3t + + ZOO2 * e3t + + DSi * e3t + + Fer * e3t + + BFe * e3t + + GOC * e3t + + SFe * e3t + + DFe * e3t + + GSi * e3t + + NFe * e3t + + NCHL * e3t + + DCHL * e3t + + NO3 * e3t + + NH4 * e3t + + + + + DON * e3t + + DOP * e3t + + PON * e3t + + POP * e3t + + GON * e3t + + GOP * e3t + + PHYN * e3t + + PHYP * e3t + + DIAN * e3t + + DIAP * e3t + + PIC * e3t + + PICN * e3t + + PICP * e3t + + PFe * e3t + + PCHL * e3t + + + + LGW * e3t + + + + DET * e3t + + DOM * e3t + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Nfix * e3t + PPPHYN * e3t + PPPHYD * e3t + PPPHYP * e3t + TPP * e3t + TPNEW * e3t + TPBFE * e3t + PBSi * e3t + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/grid_def_nemo.xml b/NEMO_4.0.4_surge/cfgs/SHARED/grid_def_nemo.xml new file mode 100644 index 0000000..b370feb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/grid_def_nemo.xml @@ -0,0 +1,180 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/namelist_ice_ref b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_ice_ref new file mode 100644 index 0000000..2a7dacb --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_ice_ref @@ -0,0 +1,270 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! SI3 namelist: +!! 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 +!------------------------------------------------------------------------------ + jpl = 5 ! number of ice categories + nlay_i = 2 ! number of ice layers + nlay_s = 1 ! number of snow layers (only 1 is working) + ln_virtual_itd = .false. ! virtual ITD mono-category parameterization (jpl=1 only) + ! i.e. enhanced thermal conductivity & virtual thin ice melting + ln_icedyn = .true. ! ice dynamics (T) or not (F) + ln_icethd = .true. ! ice thermo (T) or not (F) + rn_amax_n = 0.997 ! maximum tolerated ice concentration NH + rn_amax_s = 0.997 ! maximum tolerated ice concentration SH + cn_icerst_in = "restart_ice" ! suffix of ice restart name (input) + cn_icerst_out = "restart_ice" ! suffix of ice restart name (output) + cn_icerst_indir = "." ! directory to read input ice restarts + cn_icerst_outdir = "." ! directory to write output ice restarts +/ +!------------------------------------------------------------------------------ +&namitd ! Ice discretization +!------------------------------------------------------------------------------ + ln_cat_hfn = .true. ! ice categories are defined by a function following rn_himean**(-0.05) + rn_himean = 2.0 ! expected domain-average ice thickness (m) + ln_cat_usr = .false. ! ice categories are defined by rn_catbnd below (m) + rn_catbnd = 0.,0.45,1.1,2.1,3.7,6.0 + rn_himin = 0.1 ! minimum ice thickness (m) allowed + rn_himax = 99.0 ! maximum ice thickness (m) allowed +/ +!------------------------------------------------------------------------------ +&namdyn ! Ice dynamics +!------------------------------------------------------------------------------ + ln_dynALL = .true. ! dyn.: full ice dynamics (rheology + advection + ridging/rafting + correction) + ln_dynRHGADV = .false. ! dyn.: no ridge/raft & no corrections (rheology + advection) + ln_dynADV1D = .false. ! dyn.: only advection 1D (Schar & Smolarkiewicz 1996 test case) + ln_dynADV2D = .false. ! dyn.: only advection 2D w prescribed vel.(rn_uvice + advection) + rn_uice = 0.5 ! prescribed ice u-velocity + rn_vice = 0.5 ! prescribed ice v-velocity + rn_ishlat = 2. ! lbc : free slip (0) ; partial slip (0-2) ; no slip (2) ; strong slip (>2) + ln_landfast_L16 = .false. ! landfast: parameterization from Lemieux 2016 + rn_lf_depfra = 0.125 ! fraction of ocean depth that ice must reach to initiate landfast + ! recommended range: [0.1 ; 0.25] + rn_lf_bfr = 15. ! maximum bottom stress per unit volume [N/m3] + rn_lf_relax = 1.e-5 ! relaxation time scale to reach static friction [s-1] + rn_lf_tensile = 0.05 ! isotropic tensile strength [0-0.5??] +/ +!------------------------------------------------------------------------------ +&namdyn_rdgrft ! Ice ridging/rafting +!------------------------------------------------------------------------------ + ! -- ice_rdgrft_strength -- ! + ln_str_H79 = .true. ! ice strength param.: Hibler_79 => P = pstar**exp(-c_rhg*A) + rn_pstar = 2.0e+04 ! ice strength thickness parameter [N/m2] + rn_crhg = 20.0 ! ice strength conc. parameter (-) + ! -- ice_rdgrft -- ! + rn_csrdg = 0.5 ! fraction of shearing energy contributing to ridging + ! -- ice_rdgrft_prep -- ! + ln_partf_lin = .false. ! Linear ridging participation function (Thorndike et al, 1975) + rn_gstar = 0.15 ! fractional area of thin ice being ridged + ln_partf_exp = .true. ! Exponential ridging participation function (Lipscomb, 2007) + rn_astar = 0.03 ! exponential measure of ridging ice fraction [set to 0.05 if hstar=100] + ln_ridging = .true. ! ridging activated (T) or not (F) + rn_hstar = 25.0 ! determines the maximum thickness of ridged ice [m] (Hibler, 1980) + rn_porordg = 0.3 ! porosity of newly ridged ice (Lepparanta et al., 1995) + rn_fsnwrdg = 0.5 ! snow volume fraction that survives in ridging + rn_fpndrdg = 1.0 ! pond fraction that survives in ridging (small a priori) + ln_rafting = .true. ! rafting activated (T) or not (F) + rn_hraft = 0.75 ! threshold thickness for rafting [m] + rn_craft = 5.0 ! squeezing coefficient used in the rafting function + rn_fsnwrft = 0.5 ! snow volume fraction that survives in rafting + rn_fpndrft = 1.0 ! pond fraction that survives in rafting (0.5 a priori) +/ +!------------------------------------------------------------------------------ +&namdyn_rhg ! Ice rheology +!------------------------------------------------------------------------------ + ln_rhg_EVP = .true. ! EVP rheology + ln_aEVP = .true. ! adaptive rheology (Kimmritz et al. 2016 & 2017) + rn_creepl = 2.0e-9 ! creep limit [1/s] + rn_ecc = 2.0 ! eccentricity of the elliptical yield curve + nn_nevp = 100 ! number of EVP subcycles + rn_relast = 0.333 ! ratio of elastic timescale to ice time step: Telast = dt_ice * rn_relast + ! advised value: 1/3 (nn_nevp=100) or 1/9 (nn_nevp=300) + nn_rhg_chkcvg = 0 ! check convergence of rheology + ! = 0 no check + ! = 1 check at the main time step (output xml: uice_cvg) + ! = 2 check at both main and rheology time steps (additional output: ice_cvg.nc) + ! this option 2 asks a lot of communications between cpu +/ +!------------------------------------------------------------------------------ +&namdyn_adv ! Ice advection +!------------------------------------------------------------------------------ + ln_adv_Pra = .true. ! Advection scheme (Prather) + ln_adv_UMx = .false. ! Advection scheme (Ultimate-Macho) + nn_UMx = 5 ! order of the scheme for UMx (1-5 ; 20=centered 2nd order) +/ +!------------------------------------------------------------------------------ +&namsbc ! Ice surface boundary conditions +!------------------------------------------------------------------------------ + rn_cio = 5.0e-03 ! ice-ocean drag coefficient (-) + nn_snwfra = 2 ! calculate the fraction of ice covered by snow (for zdf and albedo) + ! = 0 fraction = 1 (if snow) or 0 (if no snow) + ! = 1 fraction = 1-exp(-0.2*rhos*hsnw) [MetO formulation] + ! = 2 fraction = hsnw / (hsnw+0.02) [CICE formulation] + rn_snwblow = 0.66 ! mesure of snow blowing into the leads + ! = 1 => no snow blowing, < 1 => some snow blowing + nn_flxdist = -1 ! Redistribute heat flux over ice categories + ! =-1 Do nothing (needs N(cat) fluxes) + ! = 0 Average N(cat) fluxes then apply the average over the N(cat) ice + ! = 1 Average N(cat) fluxes then redistribute over the N(cat) ice using T-ice and albedo sensitivity + ! = 2 Redistribute a single flux over categories + ln_cndflx = .false. ! Use conduction flux as surface boundary conditions (i.e. for Jules coupling) + ln_cndemulate = .false. ! emulate conduction flux (if not provided in the inputs) + nn_qtrice = 1 ! Solar flux transmitted thru the surface scattering layer: + ! = 0 Grenfell and Maykut 1977 (depends on cloudiness and is 0 when there is snow) + ! = 1 Lebrun 2019 (equals 0.3 anytime with different melting/dry snw conductivities) +/ +!------------------------------------------------------------------------------ +&namthd ! Ice thermodynamics +!------------------------------------------------------------------------------ + ln_icedH = .true. ! activate ice thickness change from growing/melting (T) or not (F) + ln_icedA = .true. ! activate lateral melting param. (T) or not (F) + ln_icedO = .true. ! activate ice growth in open-water (T) or not (F) + ln_icedS = .true. ! activate brine drainage (T) or not (F) + ! + ln_leadhfx = .true. ! heat in the leads is used to melt sea-ice before warming the ocean +/ +!------------------------------------------------------------------------------ +&namthd_zdf ! Ice heat diffusion +!------------------------------------------------------------------------------ + ln_zdf_BL99 = .true. ! Heat diffusion follows Bitz and Lipscomb 1999 + ln_cndi_U64 = .false. ! sea ice thermal conductivity: k = k0 + beta.S/T (Untersteiner, 1964) + ln_cndi_P07 = .true. ! sea ice thermal conductivity: k = k0 + beta1.S/T - beta2.T (Pringle et al., 2007) + rn_cnd_s = 0.31 ! thermal conductivity of the snow (0.31 W/m/K, Maykut and Untersteiner, 1971) + ! Obs: 0.1-0.5 (Lecomte et al, JAMES 2013) + rn_kappa_i = 1.0 ! radiation attenuation coefficient in sea ice [1/m] + rn_kappa_s = 10.0 ! nn_qtrice = 0: radiation attenuation coefficient in snow [1/m] + rn_kappa_smlt = 7.0 ! nn_qtrice = 1: radiation attenuation coefficient in melting snow [1/m] + rn_kappa_sdry = 10.0 ! radiation attenuation coefficient in dry snow [1/m] + ln_zdf_chkcvg = .false. ! check convergence of heat diffusion scheme (outputs: tice_cvgerr, tice_cvgstp) +/ +!------------------------------------------------------------------------------ +&namthd_da ! Ice lateral melting +!------------------------------------------------------------------------------ + rn_beta = 1.0 ! coef. beta for lateral melting param. Recommended range=[0.8-1.2] + ! => decrease = more melt and melt peaks toward higher concentration (A~0.5 for beta=1 ; A~0.8 for beta=0.2) + ! 0.3 = best fit for western Fram Strait and Antarctica + ! 1.4 = best fit for eastern Fram Strait + rn_dmin = 8. ! minimum floe diameter for lateral melting param. Recommended range=[6-10] + ! => 6 vs 8m = +40% melting at the peak (A~0.5) + ! 10 vs 8m = -20% melting +/ +!------------------------------------------------------------------------------ +&namthd_do ! Ice growth in open water +!------------------------------------------------------------------------------ + rn_hinew = 0.1 ! thickness for new ice formation in open water (m), must be larger than rn_himin + ln_frazil = .false. ! Frazil ice parameterization (ice collection as a function of wind) + rn_maxfraz = 1.0 ! maximum fraction of frazil ice collecting at the ice base + rn_vfraz = 0.417 ! thresold drift speed for frazil ice collecting at the ice bottom (m/s) + rn_Cfraz = 5.0 ! squeezing coefficient for frazil ice collecting at the ice bottom +/ +!------------------------------------------------------------------------------ +&namthd_sal ! Ice salinity +!------------------------------------------------------------------------------ + nn_icesal = 2 ! ice salinity option + ! 1: constant ice salinity (S=rn_icesal) + ! 2: varying salinity parameterization S(z,t) + ! 3: prescribed salinity profile S(z) (Schwarzacher 1959) + rn_icesal = 4. ! (nn_icesal=1) ice salinity (g/kg) + rn_sal_gd = 5. ! (nn_icesal=2) restoring ice salinity, gravity drainage (g/kg) + rn_time_gd = 1.73e+6 ! (nn_icesal=2) restoring time scale, gravity drainage (s) + rn_sal_fl = 2. ! (nn_icesal=2) restoring ice salinity, flushing (g/kg) + rn_time_fl = 8.64e+5 ! (nn_icesal=2) restoring time scale, flushing (s) + rn_simax = 20. ! maximum tolerated ice salinity (g/kg) + rn_simin = 0.1 ! minimum tolerated ice salinity (g/kg) +/ +!------------------------------------------------------------------------------ +&namthd_pnd ! Melt ponds +!------------------------------------------------------------------------------ + ln_pnd = .true. ! activate melt ponds or not + ln_pnd_LEV = .true. ! level ice melt ponds (from Flocco et al 2007,2010 & Holland et al 2012) + rn_apnd_min = 0.15 ! minimum ice fraction that contributes to melt pond. range: 0.0 -- 0.15 ?? + rn_apnd_max = 0.85 ! maximum ice fraction that contributes to melt pond. range: 0.7 -- 0.85 ?? + rn_pnd_flush= 0.01 ! pond flushing efficiency (tuning parameter) (LEV) + ln_pnd_CST = .false. ! constant melt ponds + rn_apnd = 0.2 ! prescribed pond fraction, at Tsu=0 degC + rn_hpnd = 0.05 ! prescribed pond depth, at Tsu=0 degC + ln_pnd_lids = .true. ! frozen lids on top of the ponds (only for ln_pnd_LEV) + ln_pnd_alb = .true. ! effect of melt ponds on ice albedo +/ +!------------------------------------------------------------------------------ +&namini ! Ice initialization +!------------------------------------------------------------------------------ + ln_iceini = .true. ! activate ice initialization (T) or not (F) + nn_iceini_file = 0 ! 0 = Initialise sea ice based on SSTs + ! 1 = Initialise sea ice from single category netcdf file + ! 2 = Initialise sea ice from multi category restart file + rn_thres_sst = 2.0 ! max temp. above Tfreeze with initial ice = (sst - tfreeze) + rn_hti_ini_n = 3.0 ! initial ice thickness (m), North + rn_hti_ini_s = 1.0 ! " " South + rn_hts_ini_n = 0.3 ! initial snow thickness (m), North + rn_hts_ini_s = 0.3 ! " " South + rn_ati_ini_n = 0.9 ! initial ice concentration (-), North + rn_ati_ini_s = 0.9 ! " " South + rn_smi_ini_n = 6.3 ! initial ice salinity (g/kg), North + rn_smi_ini_s = 6.3 ! " " South + rn_tmi_ini_n = 270. ! initial ice temperature (K), North + rn_tmi_ini_s = 270. ! " " South + rn_tsu_ini_n = 270. ! initial surface temperature (K), North + rn_tsu_ini_s = 270. ! " " South + rn_tms_ini_n = 270. ! initial snw temperature (K), North + rn_tms_ini_s = 270. ! " " South + rn_apd_ini_n = 0.2 ! initial pond fraction (-), North + rn_apd_ini_s = 0.2 ! " " South + rn_hpd_ini_n = 0.05 ! initial pond depth (m), North + rn_hpd_ini_s = 0.05 ! " " South + rn_hld_ini_n = 0.0 ! initial pond lid depth (m), North + rn_hld_ini_s = 0.0 ! " " South + ! -- for nn_iceini_file = 1 + sn_hti = 'Ice_initialization' , -12 ,'hti' , .false. , .true., 'yearly' , '' , '', '' + sn_hts = 'Ice_initialization' , -12 ,'hts' , .false. , .true., 'yearly' , '' , '', '' + sn_ati = 'Ice_initialization' , -12 ,'ati' , .false. , .true., 'yearly' , '' , '', '' + sn_smi = 'Ice_initialization' , -12 ,'smi' , .false. , .true., 'yearly' , '' , '', '' + sn_tmi = 'Ice_initialization' , -12 ,'tmi' , .false. , .true., 'yearly' , '' , '', '' + sn_tsu = 'Ice_initialization' , -12 ,'tsu' , .false. , .true., 'yearly' , '' , '', '' + sn_tms = 'NOT USED' , -12 ,'tms' , .false. , .true., 'yearly' , '' , '', '' + ! melt ponds (be careful, sn_apd is the pond concentration (not fraction), so it differs from rn_apd) + sn_apd = 'NOT USED' , -12 ,'apd' , .false. , .true., 'yearly' , '' , '', '' + sn_hpd = 'NOT USED' , -12 ,'hpd' , .false. , .true., 'yearly' , '' , '', '' + sn_hld = 'NOT USED' , -12 ,'hld' , .false. , .true., 'yearly' , '' , '', '' + cn_dir='./' +/ +!------------------------------------------------------------------------------ +&namalb ! albedo parameters +!------------------------------------------------------------------------------ + ! ! ! obs range (cloud-sky) + rn_alb_sdry = 0.85 ! dry snow albedo : 0.85 -- 0.87 + rn_alb_smlt = 0.75 ! melting snow albedo : 0.72 -- 0.82 + rn_alb_idry = 0.60 ! dry ice albedo : 0.54 -- 0.65 + rn_alb_imlt = 0.50 ! bare puddled ice albedo : 0.49 -- 0.58 + rn_alb_dpnd = 0.27 ! ponded ice albedo : 0.10 -- 0.30 +/ +!------------------------------------------------------------------------------ +&namdia ! Diagnostics +!------------------------------------------------------------------------------ + ln_icediachk = .false. ! check online heat, mass & salt budgets + ! ! rate of ice spuriously gained/lost at each time step => rn_icechk=1 <=> 1.e-6 m/hour + rn_icechk_cel = 100. ! check at each gridcell (1.e-4m/h)=> stops the code if violated (and writes a file) + rn_icechk_glo = 1. ! check over the entire ice cover (1.e-6m/h)=> only prints warnings + ln_icediahsb = .false. ! output the heat, mass & salt budgets (T) or not (F) + ln_icectl = .false. ! ice points output for debug (T or F) + iiceprt = 10 ! i-index for debug + jiceprt = 10 ! j-index for debug +/ diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/namelist_pisces_ref b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_pisces_ref new file mode 100644 index 0000000..37fb5da --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_pisces_ref @@ -0,0 +1,525 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! PISCES reference namelist +!! 1 - air-sea exchange (nampisext) +!! 2 - biological parameters (nampisbio) +!! 3 - parameters for nutrient limitations (nampislim) +!! 4 - parameters for phytoplankton (nampisprod,nampismort) +!! 5 - parameters for zooplankton (nampismes,nampiszoo) +!! 6 - parameters for remineralization (nampisrem) +!! 7 - parameters for calcite chemistry (nampiscal) +!! 8 - parameters for inputs deposition (nampissed) +!! 11 - Damping (nampisdmp) +!----------------------------------------------------------------------- +&nampismod ! Model used +!----------------------------------------------------------------------- + ln_p2z = .false. ! LOBSTER model used + ln_p4z = .true. ! PISCES model used + ln_p5z = .false. ! PISCES QUOTA model used + ln_ligand = .false. ! Enable organic ligands + ln_sediment = .false. ! Enable sediment module +/ +!----------------------------------------------------------------------- +&nampisext ! air-sea exchange +!----------------------------------------------------------------------- + ln_co2int = .false. ! read atm pco2 from a file (T) or constant (F) + atcco2 = 280. ! Constant value atmospheric pCO2 - ln_co2int = F + clname = 'atcco2.txt' ! Name of atm pCO2 file - ln_co2int = T + nn_offset = 0 ! Offset model-data start year - ln_co2int = T +! ! If your model year is iyy, nn_offset=(years(1)-iyy) +! ! then the first atmospheric CO2 record read is at years(1) +/ +!----------------------------------------------------------------------- +&nampisatm ! Atmospheric prrssure +!----------------------------------------------------------------------- +! ! 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_patm = 'presatm' , -1. , 'patm' , .true. , .true. , 'yearly' , '' , '' , '' + sn_atmco2 = 'presatmco2' , -1. , 'xco2' , .true. , .true. , 'yearly' , '' , '' , '' + cn_dir = './' ! root directory for the location of the dynamical files +! + ln_presatm = .false. ! constant atmopsheric pressure (F) or from a file (T) + ln_presatmco2 = .false. ! Read spatialized atm co2 files [ppm] if TRUE +/ +!----------------------------------------------------------------------- +&nampisbio ! biological parameters +!----------------------------------------------------------------------- + nrdttrc = 1 ! time step frequency for biology + wsbio = 2. ! POC sinking speed + xkmort = 2.E-7 ! half saturation constant for mortality + ferat3 = 10.E-6 ! Fe/C in zooplankton + wsbio2 = 50. ! Big particles sinking speed + wsbio2max = 50. ! Big particles maximum sinking speed + wsbio2scale = 5000. ! Big particles length scale of sinking +! ! ln_ligand enabled + ldocp = 1.E-4 ! Phyto ligand production per unit doc + ldocz = 1.E-4 ! Zoo ligand production per unit doc + lthet = 1.0 ! Proportional loss of ligands due to Fe uptake +! ! ln_p5z enabled + no3rat3 = 0.182 ! N/C ratio in zooplankton + po4rat3 = 0.0094 ! P/C ratio in zooplankton +/ +!----------------------------------------------------------------------- +&namp4zlim ! parameters for nutrient limitations for PISCES std - ln_p4z +!----------------------------------------------------------------------- + concnno3 = 1.e-6 ! Nitrate half saturation of nanophytoplankton + concdno3 = 3.E-6 ! Nitrate half saturation for diatoms + concnnh4 = 1.E-7 ! NH4 half saturation for phyto + concdnh4 = 3.E-7 ! NH4 half saturation for diatoms + concnfer = 1.E-9 ! Iron half saturation for phyto + concdfer = 3.E-9 ! Iron half saturation for diatoms + concbfe = 1.E-11 ! Iron half-saturation for DOC remin. + concbnh4 = 2.E-8 ! NH4 half saturation for DOC remin. + concbno3 = 2.E-7 ! Nitrate half saturation for DOC remin. + xsizedia = 1.E-6 ! Minimum size criteria for diatoms + xsizephy = 1.E-6 ! Minimum size criteria for phyto + xsizern = 3.0 ! Size ratio for nanophytoplankton + xsizerd = 3.0 ! Size ratio for diatoms + xksi1 = 2.E-6 ! half saturation constant for Si uptake + xksi2 = 20E-6 ! half saturation constant for Si/C + xkdoc = 417.E-6 ! half-saturation constant of DOC remineralization + qnfelim = 7.E-6 ! Optimal quota of phyto + qdfelim = 7.E-6 ! Optimal quota of diatoms + caco3r = 0.3 ! mean rain ratio + oxymin = 1.E-6 ! Half-saturation constant for anoxia +/ +!----------------------------------------------------------------------- +&namp5zlim ! parameters for nutrient limitations PISCES QUOTA - ln_p5z +!----------------------------------------------------------------------- + concnno3 = 3e-6 ! Nitrate half saturation of nanophytoplankton + concpno3 = 1e-6 + concdno3 = 4E-6 ! Phosphate half saturation for diatoms + concnnh4 = 1.5E-6 ! NH4 half saturation for phyto + concpnh4 = 4E-7 + concdnh4 = 2E-6 ! NH4 half saturation for diatoms + concnpo4 = 3E-6 ! PO4 half saturation for phyto + concppo4 = 1.5E-6 + concdpo4 = 4E-6 ! PO4 half saturation for diatoms + concnfer = 3E-9 ! Iron half saturation for phyto + concpfer = 1.5E-9 + concdfer = 4E-9 ! Iron half saturation for diatoms + concbfe = 1.E-11 ! Half-saturation for Fe limitation of Bacteria + concbnh4 = 1.E-7 ! NH4 half saturation for phyto + concbno3 = 5.E-7 ! Phosphate half saturation for diatoms + concbpo4 = 1E-7 ! Phosphate half saturation for bacteria + xsizedia = 1.E-6 ! Minimum size criteria for diatoms + xsizephy = 1.E-6 ! Minimum size criteria for phyto + xsizepic = 1.E-6 + xsizern = 1.0 ! Size ratio for nanophytoplankton + xsizerp = 1.0 + xsizerd = 4.0 ! Size ratio for diatoms + xksi1 = 2.E-6 ! half saturation constant for Si uptake + xksi2 = 20E-6 ! half saturation constant for Si/C + xkdoc = 417.E-6 ! half-saturation constant of DOC remineralization + caco3r = 0.35 ! mean rain ratio + oxymin = 1.E-6 ! Half-saturation constant for anoxia +/ +!----------------------------------------------------------------------- +&namp5zquota ! parameters for nutrient limitations PISCES quota - ln_p5z +!----------------------------------------------------------------------- + qfnopt = 7.E-6 ! Optimal Fe quota of nanophyto + qfpopt = 7.E-6 ! Optimal Fe quota of picophyto + qfdopt = 7.E-6 ! Optimal quota of diatoms + qnnmin = 0.29 ! Minimal N quota for nano + qnnmax = 1.39 ! Maximal N quota for nano + qpnmin = 0.28 ! Minimal P quota for nano + qpnmax = 1.06 ! Maximal P quota for nano + qnpmin = 0.42 ! Minimal N quota for pico + qnpmax = 1.39 ! Maximal N quota for pico + qppmin = 0.25 ! Minimal P quota for pico + qppmax = 0.7 ! Maximal P quota for pico + qndmin = 0.25 ! Minimal N quota for diatoms + qndmax = 1.39 ! Maximal N quota for diatoms + qpdmin = 0.29 ! Minimal P quota for diatoms + qpdmax = 1.32 ! Maximal P quota for diatoms + qfnmax = 40E-6 ! Maximal Fe quota for nano + qfpmax = 40E-6 ! Maximal Fe quota for pico + qfdmax = 40E-6 ! Maximal Fe quota for diatoms +/ +!----------------------------------------------------------------------- +&nampisopt ! parameters for optics +!----------------------------------------------------------------------- +! ! 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_par = 'par.orca' , 24. , 'fr_par' , .true. , .true. , 'yearly' , '' , '' , '' + cn_dir = './' ! root directory for the location of the dynamical files + ln_varpar = .true. ! boolean for PAR variable + parlux = 0.43 ! Fraction of shortwave as PAR +/ +!----------------------------------------------------------------------- +&namp4zprod ! parameters for phytoplankton growth for PISCES std - ln_p4z +!----------------------------------------------------------------------- + pislopen = 2. ! P-I slope + pisloped = 2. ! P-I slope for diatoms + xadap = 0. ! Adaptation factor to low light + excretn = 0.05 ! excretion ratio of phytoplankton + excretd = 0.05 ! excretion ratio of diatoms + bresp = 0.033 ! Basal respiration rate + chlcnm = 0.033 ! Maximum Chl/C in nanophytoplankton + chlcdm = 0.05 ! Maximum Chl/C in diatoms + chlcmin = 0.004 ! Minimum Chl/c in phytoplankton + fecnm = 40E-6 ! Maximum Fe/C in nanophytoplankton + fecdm = 40E-6 ! Maximum Fe/C in diatoms + grosip = 0.159 ! mean Si/C ratio +/ +!----------------------------------------------------------------------- +&namp5zprod ! parameters for phytoplankton growth for PISCES quota- ln_p5z +!----------------------------------------------------------------------- + pislopen = 3. ! P-I slope + pislopep = 3. ! P-I slope for picophytoplankton + pisloped = 3. ! P-I slope for diatoms + excretn = 0.05 ! excretion ratio of phytoplankton + excretp = 0.05 ! excretion ratio of picophytoplankton + excretd = 0.05 ! excretion ratio of diatoms + xadap = 0. ! Adaptation factor to low light + bresp = 0.02 ! Basal respiration rate + thetannm = 0.25 ! Maximum Chl/N in nanophytoplankton + thetanpm = 0.25 ! Maximum Chl/N in picophytoplankton + thetandm = 0.3 ! Maximum Chl/N in diatoms + chlcmin = 0.004 ! Minimum Chl/c in phytoplankton + grosip = 0.131 ! mean Si/C ratio +/ +!----------------------------------------------------------------------- +&namp4zmort ! parameters for phytoplankton sinks for PISCES std - ln_p4z +!----------------------------------------------------------------------- + wchl = 0.01 ! quadratic mortality of phytoplankton + wchld = 0.01 ! maximum quadratic mortality of diatoms + wchldm = 0.03 ! maximum quadratic mortality of diatoms + mprat = 0.01 ! phytoplankton mortality rate + mprat2 = 0.01 ! Diatoms mortality rate +/ +!----------------------------------------------------------------------- +&namp5zmort ! parameters for phytoplankton sinks for PISCES quota - ln_p5z +!----------------------------------------------------------------------- + wchln = 0.01 ! quadratic mortality of nanophytoplankton + wchlp = 0.01 ! quadratic mortality of picophytoplankton + wchld = 0.01 ! maximum quadratic mortality of diatoms + wchldm = 0.02 ! maximum quadratic mortality of diatoms + mpratn = 0.01 ! nanophytoplankton mortality rate + mpratp = 0.01 ! picophytoplankton mortality rate + mpratd = 0.01 ! Diatoms mortality rate +/ +!----------------------------------------------------------------------- +&namp4zmes ! parameters for mesozooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- + part2 = 0.75 ! part of calcite not dissolved in mesozoo guts + grazrat2 = 0.75 ! maximal mesozoo grazing rate + resrat2 = 0.005 ! exsudation rate of mesozooplankton + mzrat2 = 0.03 ! mesozooplankton mortality rate + xpref2d = 1. ! mesozoo preference for diatoms + xpref2n = 0.3 ! mesozoo preference for nanophyto. + xpref2z = 1. ! mesozoo preference for microzoo. + xpref2c = 0.3 ! mesozoo preference for poc + xthresh2zoo = 1E-8 ! zoo feeding threshold for mesozooplankton + xthresh2dia = 1E-8 ! diatoms feeding threshold for mesozooplankton + xthresh2phy = 1E-8 ! nanophyto feeding threshold for mesozooplankton + xthresh2poc = 1E-8 ! poc feeding threshold for mesozooplankton + xthresh2 = 3E-7 ! Food threshold for grazing + xkgraz2 = 20.E-6 ! half saturation constant for meso grazing + epsher2 = 0.35 ! Efficicency of Mesozoo growth + epsher2min = 0.35 ! Minimum efficiency of mesozoo growth + sigma2 = 0.6 ! Fraction of mesozoo excretion as DOM + unass2 = 0.3 ! non assimilated fraction of P by mesozoo + grazflux = 3.e3 ! flux-feeding rate +/ +!----------------------------------------------------------------------- +&namp5zmes ! parameters for mesozooplankton +!----------------------------------------------------------------------- + part2 = 0.75 ! part of calcite not dissolved in mesozoo guts + grazrat2 = 0.85 ! maximal mesozoo grazing rate + bmetexc2 = .true. ! Metabolic use of excess carbon + resrat2 = 0.005 ! exsudation rate of mesozooplankton + mzrat2 = 0.02 ! mesozooplankton mortality rate + xpref2d = 1. ! zoo preference for Diatoms + xpref2n = 1. ! zoo preference for nanophyto + xpref2z = 1. ! zoo preference for zoo + xpref2m = 0.2 ! zoo preference for mesozoo + xpref2c = 0.3 ! zoo preference for POC + xthresh2zoo = 1E-8 ! zoo feeding threshold for mesozooplankton + xthresh2dia = 1E-8 ! diatoms feeding threshold for mesozooplankton + xthresh2phy = 1E-8 ! nanophyto feeding threshold for mesozooplankton + xthresh2mes = 1E-8 ! meso feeding threshold for mesozooplankton + xthresh2poc = 1E-8 ! poc feeding threshold for mesozooplankton + xthresh2 = 3E-7 ! Food threshold for grazing + xkgraz2 = 20.E-6 ! half sturation constant for meso grazing + epsher2 = 0.5 ! Efficicency of Mesozoo growth + epsher2min = 0.2 ! Minimum efficiency of mesozoo growth + ssigma2 = 0.5 ! Fraction excreted as semi-labile DOM + srespir2 = 0.2 ! Active respiration + unass2c = 0.3 ! non assimilated fraction of P by mesozoo + unass2n = 0.3 ! non assimilated fraction of N by mesozoo + unass2p = 0.3 ! non assimilated fraction of P by mesozoo + grazflux = 3.e3 ! flux-feeding rate +/ +!----------------------------------------------------------------------- +&namp4zzoo ! parameters for microzooplankton for PISCES std - ln_p4z +!----------------------------------------------------------------------- + part = 0.5 ! part of calcite not dissolved in microzoo guts + grazrat = 3.0 ! maximal zoo grazing rate + resrat = 0.03 ! exsudation rate of zooplankton + mzrat = 0.004 ! zooplankton mortality rate + xprefc = 0.1 ! Microzoo preference for POM + xprefn = 1. ! Microzoo preference for Nanophyto + xprefd = 0.6 ! Microzoo preference for Diatoms + xthreshdia = 1.E-8 ! Diatoms feeding threshold for microzooplankton + xthreshphy = 1.E-8 ! Nanophyto feeding threshold for microzooplankton + xthreshpoc = 1.E-8 ! POC feeding threshold for microzooplankton + xthresh = 3.E-7 ! Food threshold for feeding + xkgraz = 20.E-6 ! half sturation constant for grazing + epsher = 0.3 ! Efficiency of microzoo growth + epshermin = 0.3 ! Minimum efficiency of microzoo growth + sigma1 = 0.6 ! Fraction of microzoo excretion as DOM + unass = 0.3 ! non assimilated fraction of phyto by zoo +/ +!----------------------------------------------------------------------- +&namp5zzoo ! parameters for microzooplankton +!----------------------------------------------------------------------- + part = 0.5 ! part of calcite not dissolved in microzoo gutsa + grazrat = 2.75 ! maximal zoo grazing rate + bmetexc = .true. ! Metabolic use of excess carbon + resrat = 0.03 ! exsudation rate of zooplankton + mzrat = 0.005 ! zooplankton mortality rate + xprefc = 0.1 ! Microzoo preference for POM + xprefn = 1. ! Microzoo preference for Nanophyto + xprefp = 1.6 ! Microzoo preference for picophyto + xprefd = 1.0 ! Microzoo preference for Diatoms + xprefz = 0.3 ! Microzoo preference for microzooplankton + xthreshdia = 1.E-8 ! Diatoms feeding threshold for microzooplankton + xthreshphy = 1.E-8 ! Nanophyto feeding threshold for microzooplankton + xthreshpic = 1.E-8 + xthreshzoo = 1.E-8 ! Nanophyto feeding threshold for microzooplankton + xthreshpoc = 1.E-8 ! POC feeding threshold for microzooplankton + xthresh = 3.E-7 ! Food threshold for feeding + xkgraz = 20.E-6 ! half sturation constant for grazing + epsher = 0.5 ! Efficiency of microzoo growth + epshermin = 0.2 ! Minimum efficiency of microzoo growth + ssigma = 0.5 ! Fraction excreted as semi-labile DOM + srespir = 0.2 ! Active respiration + unassc = 0.3 ! non assimilated fraction of C by zoo + unassn = 0.3 ! non assimilated fraction of C by zoo + unassp = 0.3 ! non assimilated fraction of C by zoo +/ +!----------------------------------------------------------------------- +&nampisfer ! parameters for iron chemistry +!----------------------------------------------------------------------- + ln_ligvar = .false. ! variable ligand concentration + xlam1 = 0.005 ! scavenging rate of Iron + xlamdust = 150.0 ! Scavenging rate of dust + ligand = 0.7E-9 ! Ligands concentration + kfep = 0.01 ! Nanoparticle formation rate constant +/ +!----------------------------------------------------------------------- +&nampisrem ! parameters for remineralization +!----------------------------------------------------------------------- + xremik = 0.3 ! remineralization rate of DOC + nitrif = 0.05 ! NH4 nitrification rate + xsirem = 0.003 ! remineralization rate of Si + xsiremlab = 0.03 ! fast remineralization rate of Si + xsilab = 0.5 ! Fraction of labile biogenic silica + feratb = 10.E-6 ! Fe/C quota in bacteria + xkferb = 3E-10 ! Half-saturation constant for bacteria Fe/C +! ! ln_p5z + xremikc = 0.25 ! remineralization rate of DOC + xremikn = 0.35 ! remineralization rate of DON + xremikp = 0.4 ! remineralization rate of DOP +! feratb = 20E-6 ! Bacterial Fe/C ratio +! xkferb = 3E-10 ! Half-saturation constant for bact. Fe/C +/ +!----------------------------------------------------------------------- +&nampispoc ! parameters for organic particles +!----------------------------------------------------------------------- + xremip = 0.035 ! remineralisation rate of PON + jcpoc = 15 ! Number of lability classes + rshape = 1.0 ! Shape of the gamma function +! ! ln_p5z + xremipc = 0.02 ! remineralisation rate of POC + xremipn = 0.025 ! remineralisation rate of PON + xremipp = 0.03 ! remineralisation rate of POP +/ +!----------------------------------------------------------------------- +&nampiscal ! parameters for Calcite chemistry +!----------------------------------------------------------------------- + kdca = 6. ! calcite dissolution rate constant (1/time) + nca = 1. ! order of dissolution reaction (dimensionless) +/ +!----------------------------------------------------------------------- +&nampissbc ! parameters for inputs deposition +!----------------------------------------------------------------------- +! ! 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_dust = 'dust.orca' , -1. , 'dust' , .true. , .true. , 'yearly' , '' , '' , '' + sn_solub = 'solubility.orca' , -12. , 'solubility1' , .false. , .true. , 'yearly' , '' , '' , '' + sn_riverdic = 'river.orca' , 120. , 'riverdic' , .true. , .true. , 'yearly' , '' , '' , '' + sn_riverdoc = 'river.orca' , 120. , 'riverdoc' , .true. , .true. , 'yearly' , '' , '' , '' + sn_riverdin = 'river.orca' , 120. , 'riverdin' , .true. , .true. , 'yearly' , '' , '' , '' + sn_riverdon = 'river.orca' , 120. , 'riverdon' , .true. , .true. , 'yearly' , '' , '' , '' + sn_riverdip = 'river.orca' , 120. , 'riverdip' , .true. , .true. , 'yearly' , '' , '' , '' + sn_riverdop = 'river.orca' , 120. , 'riverdop' , .true. , .true. , 'yearly' , '' , '' , '' + sn_riverdsi = 'river.orca' , 120. , 'riverdsi' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ndepo = 'ndeposition.orca', -12. , 'ndep' , .false. , .true. , 'yearly' , '' , '' , '' + sn_ironsed = 'bathy.orca' , -12. , 'bathy' , .false. , .true. , 'yearly' , '' , '' , '' + sn_hydrofe = 'hydrofe.orca' , -12. , 'epsdb' , .false. , .true. , 'yearly' , '' , '' , '' +! + cn_dir = './' ! root directory for the location of the dynamical files + ln_dust = .true. ! boolean for dust input from the atmosphere + ln_solub = .true. ! boolean for variable solubility of atm. Iron + ln_river = .true. ! boolean for river input of nutrients + ln_ndepo = .true. ! boolean for atmospheric deposition of N + 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 + sedfeinput = 2.e-9 ! Coastal release of Iron + distcoast = 5.e3 ! Distance off the coast for Iron from sediments + dustsolub = 0.02 ! Solubility of the dusta + mfrac = 0.035 ! Fe mineral fraction of dust + wdust = 2.0 ! Dust sinking speed + icefeinput = 15.e-9 ! Iron concentration in sea ice + nitrfix = 1.e-7 ! Nitrogen fixation rate + diazolight = 50. ! Diazotrophs sensitivity to light (W/m2) + concfediaz = 1.e-10 ! Diazotrophs half-saturation Cste for Iron + hratio = 1.e+7 ! Fe to 3He ratio assumed for vent iron supply +! ! ln_ligand + lgw_rath = 0.5 ! Weak ligand ratio from sed hydro sources +/ +!----------------------------------------------------------------------- +&nampislig ! Namelist parameters for ligands, nampislig +!----------------------------------------------------------------------- + rlgw = 100. ! Lifetime (years) of weak ligands + rlig = 1.E-4 ! Remin ligand production per unit C + prlgw = 1.E-4 ! Photolysis of weak ligand + rlgs = 1. ! Lifetime (years) of strong ligands +/ +!----------------------------------------------------------------------- +&nampisice ! Prescribed sea ice tracers +!----------------------------------------------------------------------- +!======================================================================== +! constant ocean tracer concentrations are defined in trcice_pisces.F90 +! (Global, Arctic, Antarctic and Baltic) +! trc_ice_ratio : >=0 & <=1 => prescribed ice/ocean tracer concentration ratio +! : = -1 => the ice-ocean tracer concentration ratio +! follows the ice-ocean salinity ratio +! : = -2 => tracer concentration in sea ice is prescribed +! and trc_ice_prescr is used +! trc_ice_prescr : prescribed tracer concentration. used only if +! trc_ice_ratio = -2. equals -99 if not used. +! cn_trc_o : = 'GL' => use global ocean values making the Baltic +! distinction only +! : = 'AA' => use specific Arctic/Antarctic/Baltic values +!======================================================================== +! sn_tri_ ! trc_ice_ratio ! trc_ice_prescr ! cn_trc_o + sn_tri_dic = -1., -99., 'AA' + sn_tri_doc = 0., -99., 'AA' + sn_tri_tal = -1., -99., 'AA' + sn_tri_oxy = -1., -99., 'AA' + sn_tri_cal = 0., -99., 'AA' + sn_tri_po4 = -1., -99., 'AA' + sn_tri_poc = 0., -99., 'AA' + sn_tri_goc = 0., -99., 'AA' + sn_tri_bfe = 0., -99., 'AA' + sn_tri_num = 0., -99., 'AA' + sn_tri_sil = -1., -99., 'AA' + sn_tri_dsi = 0., -99., 'AA' + sn_tri_gsi = 0., -99., 'AA' + sn_tri_phy = 0., -99., 'AA' + sn_tri_dia = 0., -99., 'AA' + sn_tri_zoo = 0., -99., 'AA' + sn_tri_mes = 0., -99., 'AA' + sn_tri_fer = -2., 15E-9, 'AA' + sn_tri_sfe = 0., -99., 'AA' + sn_tri_dfe = 0., -99., 'AA' + sn_tri_nfe = 0., -99., 'AA' + sn_tri_nch = 0., -99., 'AA' + sn_tri_dch = 0., -99., 'AA' + sn_tri_no3 = -1., -99., 'AA' + sn_tri_nh4 = 1., -99., 'AA' +/ +!----------------------------------------------------------------------- +&nampisdmp ! Damping +!----------------------------------------------------------------------- + ln_pisdmp = .true. ! Relaxation for some tracers to a mean value + nn_pisdmp = 5475 ! Frequency of Relaxation +/ +!----------------------------------------------------------------------- +&nampismass ! Mass conservation +!----------------------------------------------------------------------- + ln_check_mass = .false. ! Check mass conservation +/ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! PISCES reduced (key_pisces_reduced, ex LOBSTER) : namelists +!! 1 - biological parameters for phytoplankton (namlobphy) +!! 2 - biological parameters for nutrients (namlobnut) +!! 3 - biological parameters for zooplankton (namlobzoo) +!! 4 - biological parameters for detritus (namlobdet) +!! 5 - biological parameters for DOM (namlobdom) +!! 6 - parameters from aphotic layers to sediment (namlobsed) +!! 7 - general coefficients (namlobrat) +!! 8 - optical parameters (namlobopt) +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +&namlobphy ! biological parameters for phytoplankton +!----------------------------------------------------------------------- + tmumax = 1.21e-5 ! maximal phytoplankton growth rate [s-1] + rgamma = 0.05 ! phytoplankton exudation fraction [%] + fphylab = 0.75 ! NH4 fraction of phytoplankton exsudation + tmminp = 5.8e-7 ! minimal phytoplancton mortality rate [0.05/86400 s-1=20 days] + aki = 33. ! light photosynthesis half saturation constant[W/m2] +/ +!----------------------------------------------------------------------- +&namlobnut ! biological parameters for nutrients +!----------------------------------------------------------------------- + akno3 = 0.7 ! nitrate limitation half-saturation value [mmol/m3] + aknh4 = 0.001 ! ammonium limitation half-saturation value [mmol/m3] + taunn = 5.80e-7 ! nitrification rate [s-1] + psinut = 3. ! inhibition of nitrate uptake by ammonium +/ +!----------------------------------------------------------------------- +&namlobzoo ! biological parameters for zooplankton +!----------------------------------------------------------------------- + rppz = 0.8 ! zooplankton nominal preference for phytoplancton food [%] + taus = 9.26E-6 ! specific zooplankton maximal grazing rate [s-1] +! ! 0.75/86400 s-1=8.680555E-6 1/86400 = 1.15e-5 + aks = 1. ! half-saturation constant for total zooplankton grazing [mmolN.m-3] + rpnaz = 0.3 ! non-assimilated phytoplankton by zooplancton [%] + rdnaz = 0.3 ! non-assimilated detritus by zooplankton [%] + tauzn = 8.1e-7 ! zooplancton specific excretion rate [0.1/86400 s-1=10 days] + fzoolab = 0.5 ! NH4 fraction of zooplankton excretion + fdbod = 0.5 ! zooplankton mortality fraction that goes to detritus + tmminz = 2.31e-6 ! minimal zooplankton mortality rate [(mmolN/m3)-1 d-1] +/ +!----------------------------------------------------------------------- +&namlobdet ! biological parameters for detritus +!----------------------------------------------------------------------- + taudn = 5.80e-7 ! detritus breakdown rate [0.1/86400 s-1=10 days] + fdetlab = 0. ! NH4 fraction of detritus dissolution +/ +!----------------------------------------------------------------------- +&namlobdom ! biological parameters for DOM +!----------------------------------------------------------------------- + taudomn = 6.43e-8 ! DOM breakdown rate [s-1] +! ! slow remineralization rate of semi-labile dom to nh4 (1 month) +/ +!----------------------------------------------------------------------- +&namlobsed ! parameters from aphotic layers to sediment +!----------------------------------------------------------------------- + sedlam = 3.86e-7 ! time coefficient of POC remineralization in sediments [s-1] + sedlostpoc = 0. ! mass of POC lost in sediments + vsed = 3.47e-5 ! detritus sedimentation speed [m/s] + xhr = -0.858 ! coeff for martin''s remineralisation profile +/ +!----------------------------------------------------------------------- +&namlobrat ! general coefficients +!----------------------------------------------------------------------- + rcchl = 60. ! Carbone/Chlorophyl ratio [mgC.mgChla-1] + redf = 6.56 ! redfield ratio (C:N) for phyto + reddom = 6.56 ! redfield ratio (C:N) for DOM +/ +!----------------------------------------------------------------------- +&namlobopt ! optical parameters +!----------------------------------------------------------------------- + xkg0 = 0.0232 ! green absorption coefficient of water + xkr0 = 0.225 ! red absorption coefficent of water + xkgp = 0.074 ! green absorption coefficient of chl + xkrp = 0.037 ! red absorption coefficient of chl + xlg = 0.674 ! green chl exposant for absorption + xlr = 0.629 ! red chl exposant for absorption + rpig = 0.7 ! chla/chla+pheo ratio +/ diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/namelist_ref b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_ref new file mode 100644 index 0000000..f0d5a35 --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_ref @@ -0,0 +1,1383 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : Reference namelist_ref !! +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/OCE : 1 - Domain & run manager (namrun, namcfg, namdom, namtsd, namcrs, namc1d, namc1d_uvd) +!! namelists 2 - Surface boundary (namsbc, namsbc_flx, namsbc_blk, namsbc_cpl, +!! namsbc_sas, namtra_qsr, namsbc_rnf, +!! namsbc_isf, namsbc_iscpl, namsbc_apr, +!! namsbc_ssr, namsbc_wave, namberg) +!! 3 - lateral boundary (namlbc, namagrif, nambdy, nambdy_tide) +!! 4 - top/bot boundary (namdrg, namdrg_top, namdrg_bot, nambbc, nambbl) +!! 5 - Tracer (nameos, namtra_adv, namtra_ldf, namtra_eiv, namtra_dmp) +!! 6 - dynamics (namdyn_adv, namdyn_vor, namdyn_hpg, namdyn_spg, namdyn_ldf) +!! 7 - Vertical physics (namzdf, namzdf_ric, namzdf_tke, namzdf_gls, namzdf_iwm) +!! 8 - diagnostics (namnc4, namtrd, namspr, namflo, namhsb) +!! 9 - Obs & Assim (namobs, nam_asminc) +!! 10 - miscellaneous (nammpp, namctl, namsto) +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!!====================================================================== +!! *** 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 ("key_c1d") +!! namc1d_dyndmp 1D newtonian damping applied on currents ("key_c1d") +!! namc1d_uvd 1D data (currents) ("key_c1d") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namrun ! parameters of the run +!----------------------------------------------------------------------- + nn_no = 0 ! Assimilation cycle index + cn_exp = "ORCA2" ! experience name + nn_it000 = 1 ! first time step + nn_itend = 5840 ! last time step (std 5840) + nn_date0 = 010101 ! date at nit_0000 (format yyyymmdd) used if ln_rstart=F or (ln_rstart=T and nn_rstctl=0 or 1) + nn_time0 = 0 ! initial time of day in hhmm + nn_leapy = 0 ! Leap year calendar (1) or not (0) + ln_rstart = .false. ! start from rest (F) or from a restart file (T) + nn_euler = 1 ! = 0 : start with forward time step if ln_rstart=T + nn_rstctl = 0 ! restart control ==> activated only if ln_rstart=T + ! ! = 0 nn_date0 read in namelist ; nn_it000 : read in namelist + ! ! = 1 nn_date0 read in namelist ; nn_it000 : check consistancy between namelist and restart + ! ! = 2 nn_date0 read in restart ; nn_it000 : check consistancy between namelist and restart + cn_ocerst_in = "restart" ! suffix of ocean restart name (input) + cn_ocerst_indir = "." ! directory from which to read input ocean restarts + cn_ocerst_out = "restart" ! suffix of ocean restart name (output) + cn_ocerst_outdir = "." ! directory in which to write output ocean restarts + ln_iscpl = .false. ! cavity evolution forcing or coupling to ice sheet model + nn_istate = 0 ! output the initial state (1) or not (0) + ln_rst_list = .false. ! output restarts at list of times using nn_stocklist (T) or at set frequency with nn_stock (F) + nn_stock = 0 ! used only if ln_rst_list = F: output restart freqeuncy (modulo referenced to 1) + ! ! = 0 force to write restart files only at the end of the run + ! ! = -1 do not do any restart + nn_stocklist = 0,0,0,0,0,0,0,0,0,0 ! List of timesteps when a restart file is to be written + nn_write = 0 ! used only if key_iomput is not defined: output frequency (modulo referenced to nn_it000) + ! ! = 0 force to write output files only at the end of the run + ! ! = -1 do not do any output file + ln_mskland = .false. ! mask land points in NetCDF outputs + ln_cfmeta = .false. ! output additional data to netCDF files required for compliance with the CF metadata standard + ln_clobber = .true. ! clobber (overwrite) an existing file + nn_chunksz = 0 ! chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + ln_xios_read = .FALSE. ! use XIOS to read restart file (only for a single file restart) + nn_wxios = 0 ! use XIOS to write restart file 0 - no, 1 - single file output, 2 - multiple file output + ln_rst_eos = .TRUE. ! check if the equation of state used to produce the restart is consistent with model +/ +!----------------------------------------------------------------------- +&namdom ! time and space domain +!----------------------------------------------------------------------- + ln_linssh = .false. ! =T linear free surface ==>> model level are fixed in time + rn_isfhmin = 1.00 ! treshold [m] to discriminate grounding ice from floating ice + ! + rn_rdt = 5400. ! time step for the dynamics and tracer + rn_atfp = 0.1 ! asselin time filter parameter + ! + ln_crs = .false. ! Logical switch for coarsening module (T => fill namcrs) + ! + ln_2d = .false. ! (=T) run in 2D barotropic mode (no tracer processes or vertical diffusion) + ! + ln_meshmask = .false. ! =T create a mesh file +/ +!----------------------------------------------------------------------- +&namcfg ! parameters of the configuration (default: use namusr_def in namelist_cfg) +!----------------------------------------------------------------------- + ln_read_cfg = .false. ! (=T) read the domain configuration file + ! ! (=F) user defined configuration (F => create/check namusr_def) + cn_domcfg = "domain_cfg" ! domain configuration filename + ! + ln_closea = .false. ! T => keep closed seas (defined by closea_mask field) in the + ! ! domain and apply special treatment of freshwater fluxes. + ! ! F => suppress closed seas (defined by closea_mask field) + ! ! from the bathymetry at runtime. + ! ! If closea_mask field doesn't exist in the domain_cfg file + ! ! then this logical does nothing. + ln_write_cfg = .false. ! (=T) create the domain configuration file + cn_domcfg_out = "domain_cfg_out" ! newly created domain configuration filename + ! + ln_use_jattr = .false. ! use (T) the file attribute: open_ocean_jstart, if present + ! ! in netcdf input files, as the start j-row for reading +/ +!----------------------------------------------------------------------- +&namtsd ! Temperature & Salinity Data (init/dmp) (default: OFF) +!----------------------------------------------------------------------- + ! ! =T read T-S fields for: + ln_tsd_init = .false. ! ocean initialisation + ln_tsd_dmp = .false. ! 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' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namwad ! Wetting and Drying (WaD) (default: OFF) +!----------------------------------------------------------------------- + ln_wd_il = .false. ! T/F activation of iterative limiter + ln_wd_dl = .false. ! T/F activation of directional limiter + ln_wd_dl_bc = .false. ! T/F Directional limiteer Baroclinic option + ln_wd_dl_rmp = .false. ! T/F Turn on directional limiter ramp + rn_wdmin0 = 0.30 ! depth at which WaD starts + rn_wdmin1 = 0.2 ! Minimum wet depth on dried cells + rn_wdmin2 = 0.0001 ! Tolerance of min wet depth on dried cells + rn_wdld = 2.5 ! Land elevation below which WaD is allowed + nn_wdit = 20 ! Max iterations for WaD limiter + rn_wd_sbcdep = 5.0 ! Depth at which to taper sbc fluxes + rn_wd_sbcfra = 0.999 ! Fraction of SBC fluxes at taper depth (Must be <1) +/ +!----------------------------------------------------------------------- +&namcrs ! coarsened grid (for outputs and/or TOP) (ln_crs =T) +!----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_binref = 0 ! Bin centering preference: NORTH or EQUAT + ! ! 0, coarse grid is binned with preferential treatment of the north fold + ! ! 1, coarse grid is binned with centering at the equator + ! ! Symmetry with nn_facty being odd-numbered. Asymmetry with even-numbered nn_facty. + ln_msh_crs = .false. ! =T create a mesh & mask file + nn_crs_kz = 0 ! 0, MEAN of volume boxes + ! ! 1, MAX of boxes + ! ! 2, MIN of boxes + ln_crs_wn = .true. ! wn coarsened (T) or computed using horizontal divergence ( F ) +/ +!----------------------------------------------------------------------- +&namc1d ! 1D configuration options ("key_c1d" default: PAPA station) +!----------------------------------------------------------------------- + rn_lat1d = 50 ! Column latitude + rn_lon1d = -145 ! Column longitude + ln_c1d_locpt = .true. ! Localization of 1D config in a grid (T) or independant point (F) +/ +!----------------------------------------------------------------------- +&namc1d_dyndmp ! U & V newtonian damping ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ln_dyndmp = .false. ! add a damping term (T) or not (F) +/ +!----------------------------------------------------------------------- +&namc1d_uvd ! data: U & V currents ("key_c1d" default: OFF) +!----------------------------------------------------------------------- + ! ! =T read U-V fields for: + ln_uvd_init = .false. ! ocean initialisation + ln_uvd_dyndmp = .false. ! U-V restoring + + cn_dir = './' ! root directory for the U-V 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_ucur = 'ucurrent' , -1. ,'u_current', .false. , .true. , 'monthly' , '' , 'Ume' , '' + sn_vcur = 'vcurrent' , -1. ,'v_current', .false. , .true. , 'monthly' , '' , 'Vme' , '' +/ + +!!====================================================================== +!! *** 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 = 2 ! frequency of SBC module call + ! ! (control sea-ice & iceberg model call) + ! Type of air-sea fluxes + ln_usr = .false. ! user defined formulation (T => check usrdef_sbc) + ln_flx = .false. ! flux formulation (T => fill namsbc_flx ) + ln_blk = .false. ! Bulk formulation (T => fill namsbc_blk ) + ! ! Type of coupling (Ocean/Ice/Atmosphere) : + ln_cpl = .false. ! atmosphere coupled formulation ( requires key_oasis3 ) + ln_mixcpl = .false. ! forced-coupled mixed formulation ( requires key_oasis3 ) + nn_components = 0 ! configuration of the opa-sas OASIS coupling + ! ! =0 no opa-sas OASIS coupling: default single executable config. + ! ! =1 opa-sas OASIS coupling: multi executable config., OPA component + ! ! =2 opa-sas OASIS coupling: multi executable config., SAS component + ! Sea-ice : + nn_ice = 0 ! =0 no ice boundary condition + ! ! =1 use observed ice-cover ( => fill namsbc_iif ) + ! ! =2 or 3 automatically for SI3 or CICE ("key_si3" or "key_cice") + ! ! except in AGRIF zoom where it has to be specified + ln_ice_embd = .false. ! =T embedded sea-ice (pressure + mass and salt exchanges) + ! ! =F levitating ice (no pressure, mass and salt exchanges) + ! Misc. options of sbc : + ln_traqsr = .false. ! Light penetration in the ocean (T => fill namtra_qsr) + ln_dm2dc = .false. ! daily mean to diurnal cycle on short wave + ln_ssr = .false. ! Sea Surface Restoring on T and/or S (T => fill namsbc_ssr) + nn_fwb = 0 ! FreshWater Budget: =0 unchecked + ! ! =1 global mean of e-p-r set to zero at each time step + ! ! =2 annual global mean of e-p-r set to zero + ln_rnf = .false. ! runoffs (T => fill namsbc_rnf) + ln_apr_dyn = .false. ! Patm gradient added in ocean & ice Eqs. (T => fill namsbc_apr ) + ln_isf = .false. ! ice shelf (T => fill namsbc_isf & namsbc_iscpl) + ln_wave = .false. ! Activate coupling with wave (T => fill namsbc_wave) + ln_cdgw = .false. ! Neutral drag coefficient read from wave model (T => ln_wave=.true. & fill namsbc_wave) + ln_sdw = .false. ! Read 2D Surf Stokes Drift & Computation of 3D stokes drift (T => ln_wave=.true. & fill namsbc_wave) + nn_sdrift = 0 ! Parameterization for the calculation of 3D-Stokes drift from the surface Stokes drift + ! ! = 0 Breivik 2015 parameterization: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] + ! ! = 1 Phillips: v_z=v_o*[exp(2*k*z)-beta*sqrt(-2*k*pi*z)*erfc(sqrt(-2*k*z))] + ! ! = 2 Phillips as (1) but using the wave frequency from a wave model + ln_tauwoc = .false. ! Activate ocean stress modified by external wave induced stress (T => ln_wave=.true. & fill namsbc_wave) + ln_tauw = .false. ! Activate ocean stress components from wave model + ln_stcor = .false. ! Activate Stokes Coriolis term (T => ln_wave=.true. & ln_sdw=.true. & fill namsbc_wave) + nn_lsm = 0 ! =0 land/sea mask for input fields is not applied (keep empty land/sea mask filename field) , + ! =1:n number of iterations of land/sea mask application for input fields (fill land/sea mask filename field) +/ +!----------------------------------------------------------------------- +&namsbc_flx ! surface boundary condition : flux formulation (ln_flx =T) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the fluxes 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_utau = 'utau' , 24. , 'utau' , .false. , .false., 'yearly' , '' , '' , '' + sn_vtau = 'vtau' , 24. , 'vtau' , .false. , .false., 'yearly' , '' , '' , '' + sn_qtot = 'qtot' , 24. , 'qtot' , .false. , .false., 'yearly' , '' , '' , '' + sn_qsr = 'qsr' , 24. , 'qsr' , .false. , .false., 'yearly' , '' , '' , '' + sn_emp = 'emp' , 24. , 'emp' , .false. , .false., 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_blk ! namsbc_blk generic Bulk formula (ln_blk =T) +!----------------------------------------------------------------------- + ! ! bulk algorithm : + ln_NCAR = .false. ! "NCAR" algorithm (Large and Yeager 2008) + ln_COARE_3p0 = .false. ! "COARE 3.0" algorithm (Fairall et al. 2003) + ln_COARE_3p5 = .false. ! "COARE 3.5" algorithm (Edson et al. 2013) + ln_ECMWF = .false. ! "ECMWF" algorithm (IFS cycle 31) + ! + rn_zqt = 10. ! Air temperature & humidity reference height (m) + rn_zu = 10. ! Wind vector reference height (m) + ln_Cd_L12 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2012) + ln_Cd_L15 = .false. ! air-ice drags = F(ice concentration) (Lupkes et al. 2015) + ln_taudif = .false. ! HF tau contribution: use "mean of stress module - module of the mean stress" data + rn_pfac = 1. ! multiplicative factor for precipitation (total & snow) + rn_efac = 1. ! multiplicative factor for evaporation (0. or 1.) + rn_vfac = 0. ! multiplicative factor for ocean & ice velocity used to + ! ! calculate the wind stress (0.=absolute or 1.=relative winds) + + 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_core_orca2_bicubic_noc.nc' , 'Uwnd' , '' + sn_wndj = 'v_10.15JUNE2009_fill' , 6. , 'V_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bicubic_noc.nc' , 'Vwnd' , '' + sn_qsr = 'ncar_rad.15JUNE2009_fill' , 24. , 'SWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_qlw = 'ncar_rad.15JUNE2009_fill' , 24. , 'LWDN_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tair = 't_10.15JUNE2009_fill' , 6. , 'T_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_humi = 'q_10.15JUNE2009_fill' , 6. , 'Q_10_MOD', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_prec = 'ncar_precip.15JUNE2009_fill', -1. , 'PRC_MOD1', .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_snow = 'ncar_precip.15JUNE2009_fill', -1. , 'SNOW' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_slp = 'slp.15JUNE2009_fill' , 6. , 'SLP' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_cc = 'NOT USED' , 24. , 'CC' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' + sn_tdif = 'taudif_core' , 24. , 'taudif' , .false. , .true. , 'yearly' , 'weights_core_orca2_bilinear_noc.nc' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_cpl ! coupled ocean/atmosphere model ("key_oasis3") +!----------------------------------------------------------------------- + nn_cplmodel = 1 ! Maximum number of models to/from which NEMO is potentially sending/receiving data + ln_usecplmask = .false. ! 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) + ln_scale_ice_flux = .false. ! use ice fluxes that are already "ice weighted" ( i.e. multiplied ice concentration) + nn_cats_cpl = 5 ! Number of sea ice categories over which coupling is to be carried out (if not 1) + !_____________!__________________________!____________!_____________!______________________!________! + ! ! description ! multiple ! vector ! vector ! vector ! + ! ! ! categories ! reference ! orientation ! grids ! +!*** send *** + sn_snd_temp = 'weighted oce and ice' , 'no' , '' , '' , '' + sn_snd_alb = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick = 'none' , 'no' , '' , '' , '' + sn_snd_crt = 'none' , 'no' , 'spherical' , 'eastward-northward' , 'T' + sn_snd_co2 = 'coupled' , 'no' , '' , '' , '' + sn_snd_crtw = 'none' , 'no' , '' , '' , 'U,V' + sn_snd_ifrac = 'none' , 'no' , '' , '' , '' + sn_snd_wlev = 'coupled' , 'no' , '' , '' , '' + sn_snd_cond = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_thick1 = 'ice and snow' , 'no' , '' , '' , '' + sn_snd_mpnd = 'weighted ice' , 'no' , '' , '' , '' + sn_snd_sstfrz = 'coupled' , 'no' , '' , '' , '' + sn_snd_ttilyr = 'weighted ice' , 'no' , '' , '' , '' +!*** receive *** + sn_rcv_w10m = 'none' , 'no' , '' , '' , '' + sn_rcv_taumod = 'coupled' , 'no' , '' , '' , '' + sn_rcv_tau = 'oce only' , 'no' , 'cartesian' , 'eastward-northward' , 'U,V' + sn_rcv_dqnsdt = 'coupled' , 'no' , '' , '' , '' + sn_rcv_qsr = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_qns = 'oce and ice' , 'no' , '' , '' , '' + sn_rcv_emp = 'conservative' , 'no' , '' , '' , '' + sn_rcv_rnf = 'coupled' , 'no' , '' , '' , '' + sn_rcv_cal = 'coupled' , 'no' , '' , '' , '' + sn_rcv_co2 = 'coupled' , 'no' , '' , '' , '' + sn_rcv_hsig = 'none' , 'no' , '' , '' , '' + sn_rcv_iceflx = 'none' , 'no' , '' , '' , '' + sn_rcv_mslp = 'none' , 'no' , '' , '' , '' + sn_rcv_phioc = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfx = 'none' , 'no' , '' , '' , '' + sn_rcv_sdrfy = 'none' , 'no' , '' , '' , '' + sn_rcv_wper = 'none' , 'no' , '' , '' , '' + sn_rcv_wnum = 'none' , 'no' , '' , '' , '' + sn_rcv_wfreq = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' + sn_rcv_ts_ice = 'none' , 'no' , '' , '' , '' + sn_rcv_isf = 'none' , 'no' , '' , '' , '' + sn_rcv_icb = 'none' , 'no' , '' , '' , '' + sn_rcv_tauwoc = 'none' , 'no' , '' , '' , '' + sn_rcv_tauw = 'none' , 'no' , '' , '' , '' + sn_rcv_wdrag = 'none' , 'no' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_sas ! Stand-Alone Surface module: ocean data (SAS_SRC only) +!----------------------------------------------------------------------- + l_sasread = .true. ! =T Read in file ; =F set all to 0. (see sbcssm) + ln_3d_uve = .false. ! specify whether we are supplying a 3D u,v and e3 field + ln_read_frq = .false. ! specify whether we must read frq or not + + cn_dir = './' ! root directory for the ocean 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_usp = 'sas_grid_U' , 120. , 'uos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vsp = 'sas_grid_V' , 120. , 'vos' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tem = 'sas_grid_T' , 120. , 'sosstsst', .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'sas_grid_T' , 120. , 'sosaline', .true. , .true. , 'yearly' , '' , '' , '' + sn_ssh = 'sas_grid_T' , 120. , 'sossheig', .true. , .true. , 'yearly' , '' , '' , '' + sn_e3t = 'sas_grid_T' , 120. , 'e3t_m' , .true. , .true. , 'yearly' , '' , '' , '' + sn_frq = 'sas_grid_T' , 120. , 'frq_m' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iif ! Ice-IF : use observed ice cover (nn_ice = 1) +!----------------------------------------------------------------------- + cn_dir = './' ! root directory for the ice cover 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_ice ='ice_cover_clim.nc' , -12. ,'ice_cover', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namtra_qsr ! penetrative solar radiation (ln_traqsr =T) +!----------------------------------------------------------------------- + ! ! type of penetration (default: NO selection) + ln_qsr_rgb = .false. ! RGB light penetration (Red-Green-Blue) + ln_qsr_2bd = .false. ! 2BD light penetration (two bands) + ln_qsr_bio = .false. ! bio-model light penetration + ! ! RGB & 2BD choices: + rn_abs = 0.58 ! RGB & 2BD: fraction absorbed in the very near surface + rn_si0 = 0.35 ! RGB & 2BD: shortess depth of extinction + nn_chldta = 0 ! RGB : Chl data (=1) or cst value (=0) + rn_si1 = 23.0 ! 2BD : longest depth of extinction + + 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_sstr = 0 ! add a retroaction term to the surface heat flux (=1) or not (=0) + rn_dqdt = -40. ! magnitude of the retroaction on temperature [W/m2/K] + nn_sssr = 0 ! add a damping term to the surface freshwater flux (=2) + ! ! or to SSS only (=1) or no damping term (=0) + 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] + nn_sssr_ice = 1 ! control of sea surface restoring under sea-ice + ! 0 = no restoration under ice : * (1-icefrac) + ! 1 = restoration everywhere + ! >1 = enhanced restoration under ice : 1+(nn_icedmp-1)*icefrac + cn_dir = './' ! root directory for the SST/SSS 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_sst = 'sst_data' , 24. , 'sst' , .false. , .false., 'yearly' , '' , '' , '' + sn_sss = 'sss_data' , -1. , 'sss' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_rnf ! runoffs (ln_rnf =T) +!----------------------------------------------------------------------- + ln_rnf_mouth = .false. ! 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 + ln_rnf_depth = .false. ! read in depth information for runoff + ln_rnf_tem = .false. ! read in temperature information for runoff + ln_rnf_sal = .false. ! read in salinity information for runoff + ln_rnf_depth_ini = .false. ! compute depth at initialisation from runoff file + rn_rnf_max = 5.735e-4 ! max value of the runoff climatologie over global domain ( ln_rnf_depth_ini = .true ) + rn_dep_max = 150. ! depth over which runoffs is spread ( ln_rnf_depth_ini = .true ) + nn_rnf_depth_file = 0 ! create (=1) a runoff depth file or not (=0) + ln_rnf_icb = .false. ! read in iceberg flux from a file (fill sn_i_rnf if .true.) + + cn_dir = './' ! root directory for the runoff 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_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' , '' , '' , '' + sn_i_rnf = 'NOT_USED' , -1. , 'sorunoff', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_apr ! Atmospheric pressure used as ocean forcing (ln_apr_dyn =T) +!----------------------------------------------------------------------- + rn_pref = 101000. ! reference atmospheric pressure [N/m2]/ + ln_ref_apr = .false. ! ref. pressure: global mean Patm (T) or a constant (F) + ln_apr_obc = .false. ! inverse barometer added to OBC ssh data + + cn_dir = './' ! root directory for the Patm 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_apr = 'patm' , -1. ,'somslpre' , .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_isf ! Top boundary layer (ISF) (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + ! ! type of top boundary layer + nn_isf = 1 ! ice shelf melting/freezing + ! 1 = presence of ISF ; 2 = bg03 parametrisation + ! 3 = rnf file for ISF ; 4 = ISF specified freshwater flux + ! options 1 and 4 need ln_isfcav = .true. (domzgr) + ! ! nn_isf = 1 or 2 cases: + rn_gammat0 = 1.e-4 ! gammat coefficient used in blk formula + rn_gammas0 = 1.e-4 ! gammas coefficient used in blk formula + ! ! nn_isf = 1 or 4 cases: + rn_hisf_tbl = 30. ! thickness of the top boundary layer (Losh et al. 2008) + ! ! 0 => thickness of the tbl = thickness of the first wet cell + ! ! nn_isf = 1 case + nn_isfblk = 1 ! 1 ISOMIP like: 2 equations formulation (Hunter et al., 2006) + ! ! 2 ISOMIP+ like: 3 equations formulation (Asay-Davis et al., 2015) + nn_gammablk = 1 ! 0 = cst Gammat (= gammat/s) + ! ! 1 = velocity dependend Gamma (u* * gammat/s) (Jenkins et al. 2010) + ! ! 2 = velocity and stability dependent Gamma (Holland et al. 1999) + + !___________!_____________!___________________!___________!_____________!_________!___________!__________!__________!_______________! + ! ! 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 ! +!* nn_isf = 4 case + sn_fwfisf = 'rnfisf' , -12. ,'sowflisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 3 case + sn_rnfisf = 'rnfisf' , -12. ,'sofwfisf' , .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 and 3 cases + sn_depmax_isf ='rnfisf' , -12. ,'sozisfmax', .false. , .true. , 'yearly' , '' , '' , '' + sn_depmin_isf ='rnfisf' , -12. ,'sozisfmin', .false. , .true. , 'yearly' , '' , '' , '' +!* nn_isf = 2 case + sn_Leff_isf = 'rnfisf' , -12. ,'Leff' , .false. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namsbc_iscpl ! land ice / ocean coupling option (ln_isfcav =T : read (ln_read_cfg=T) +!----------------------------------------------------------------------- or set or usr_def_zgr ) + nn_drown = 10 ! number of iteration of the extrapolation loop (fill the new wet cells) + ln_hsb = .false. ! activate conservation module (conservation exact after a time of rn_fiscpl) + nn_fiscpl = 43800 ! (number of time step) conservation period (maybe should be fix to the coupling frequencey of restart frequency) +/ +!----------------------------------------------------------------------- +&namsbc_wave ! External fields from wave model (ln_wave=T) +!----------------------------------------------------------------------- + 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_wfr = 'sdw_ecwaves_orca2' , 6. , 'wfr' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnum = 'sdw_ecwaves_orca2' , 6. , 'wave_num' , .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwoc = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwx = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' + sn_tauwy = 'sdw_ecwaves_orca2' , 6. , 'wave_stress', .true. , .true. , 'yearly' , '' , '' , '' +/ +!----------------------------------------------------------------------- +&namberg ! iceberg parameters (default: OFF) +!----------------------------------------------------------------------- + ln_icebergs = .false. ! activate iceberg floats (force =F with "key_agrif") + ! + ! ! diagnostics: + ln_bergdia = .true. ! Calculate budgets + nn_verbose_level = 0 ! Turn on more verbose output if level > 0 + nn_verbose_write = 15 ! Timesteps between verbose messages + nn_sample_rate = 1 ! Timesteps between sampling for trajectory storage + ! + ! ! iceberg setting: + ! ! Initial mass required for an iceberg of each class + rn_initial_mass = 8.8e7, 4.1e8, 3.3e9, 1.8e10, 3.8e10, 7.5e10, 1.2e11, 2.2e11, 3.9e11, 7.4e11 + ! ! Proportion of calving mass to apportion to each class + rn_distribution = 0.24, 0.12, 0.15, 0.18, 0.12, 0.07, 0.03, 0.03, 0.03, 0.02 + ! ! Ratio between effective and real iceberg mass (non-dim) + ! ! i.e. number of icebergs represented at a point + rn_mass_scaling = 2000., 200., 50., 20., 10., 5., 2., 1., 1., 1. + ! thickness of newly calved bergs (m) + rn_initial_thickness = 40., 67., 133., 175., 250., 250., 250., 250., 250., 250. + ! + rn_rho_bergs = 850. ! Density of icebergs + rn_LoW_ratio = 1.5 ! Initial ratio L/W for newly calved icebergs + ln_operator_splitting = .true. ! Use first order operator splitting for thermodynamics + rn_bits_erosion_fraction = 0. ! Fraction of erosion melt flux to divert to bergy bits + rn_sicn_shift = 0. ! Shift of sea-ice concn in erosion flux (0 0 + rn_speed_limit = 0. ! CFL speed limit for a berg + + cn_dir = './' ! root directory for the calving 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_icb = 'calving' , -1. ,'calvingmask', .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) +!----------------------------------------------------------------------- + ! ! free slip ! partial slip ! no slip ! strong slip + rn_shlat = -9999. ! shlat = 0 ! 0 < shlat < 2 ! shlat = 2 ! 2 < shlat + ln_vorlat = .false. ! consistency of vorticity boundary condition with analytical Eqs. +/ +!----------------------------------------------------------------------- +&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 +/ +!----------------------------------------------------------------------- +&nam_tide ! tide parameters (default: OFF) +!----------------------------------------------------------------------- + ln_tide = .false. ! Activate tides + ln_tide_pot = .true. ! use tidal potential forcing + ln_scal_load = .false. ! Use scalar approximation for + rn_scal_load = 0.094 ! load potential + ln_read_load = .false. ! Or read load potential from file + cn_tide_load = 'tide_LOAD_grid_T.nc' ! filename for load potential + ! + ln_tide_ramp = .false. ! Use linear ramp for tides at startup + rdttideramp = 0. ! ramp duration in days + clname(1) = 'DUMMY' ! name of constituent - all tidal components must be set in namelist_cfg +/ +!----------------------------------------------------------------------- +&nambdy ! unstructured open boundaries (default: OFF) +!----------------------------------------------------------------------- + ln_bdy = .false. ! Use unstructured open boundaries + nb_bdy = 0 ! number of open boundary sets + ln_coords_file = .true. ! =T : read bdy coordinates from file + cn_coords_file = 'coordinates.bdy.nc' ! bdy coordinates files + ln_mask_file = .false. ! =T : read mask from file + cn_mask_file = '' ! name of mask file (if ln_mask_file=.TRUE.) + cn_dyn2d = 'none' ! + nn_dyn2d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! ! = 2, use tidal harmonic forcing data from files + ! ! = 3, use external data AND tidal harmonic forcing + cn_dyn3d = 'none' ! + nn_dyn3d_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_tra = 'none' ! + nn_tra_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + cn_ice = 'none' ! + nn_ice_dta = 0 ! = 0, bdy data are equal to the initial state + ! ! = 1, bdy data are read in 'bdydata .nc' files + ! + ln_tra_dmp =.false. ! open boudaries conditions for tracers + ln_dyn3d_dmp =.false. ! open boundary condition for baroclinic velocities + rn_time_dmp = 1. ! Damping time scale in days + rn_time_dmp_out = 1. ! Outflow damping time scale + nn_rimwidth = 10 ! width of the relaxation zone + ln_vol = .false. ! total volume correction (see nn_volctl parameter) + nn_volctl = 1 ! = 0, the total water flux across open boundaries is zero +/ +!----------------------------------------------------------------------- +&nambdy_dta ! open boundaries - external data (see nam_bdy) +!----------------------------------------------------------------------- + ln_zinterp = .false. ! T if a vertical interpolation is required. Variables gdep[tuv] and e3[tuv] must exist in the file + ! ! automatically defined to T if the number of vertical levels in bdy dta /= jpk + ln_full_vel = .false. ! T if [uv]3d are "full" velocities and not only its baroclinic components + ! ! in this case, baroclinic and barotropic velocities will be recomputed -> [uv]2d not needed + ! + cn_dir = 'bdydta/' ! root directory for the BDY 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 ! + bn_ssh = 'amm12_bdyT_u2d' , 24. , 'sossheig', .true. , .false., 'daily' , '' , '' , '' + bn_u2d = 'amm12_bdyU_u2d' , 24. , 'vobtcrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v2d = 'amm12_bdyV_u2d' , 24. , 'vobtcrty', .true. , .false., 'daily' , '' , '' , '' + bn_u3d = 'amm12_bdyU_u3d' , 24. , 'vozocrtx', .true. , .false., 'daily' , '' , '' , '' + bn_v3d = 'amm12_bdyV_u3d' , 24. , 'vomecrty', .true. , .false., 'daily' , '' , '' , '' + bn_tem = 'amm12_bdyT_tra' , 24. , 'votemper', .true. , .false., 'daily' , '' , '' , '' + bn_sal = 'amm12_bdyT_tra' , 24. , 'vosaline', .true. , .false., 'daily' , '' , '' , '' +!* for si3 + bn_a_i = 'amm12_bdyT_ice' , 24. , 'siconc' , .true. , .false., 'daily' , '' , '' , '' + bn_h_i = 'amm12_bdyT_ice' , 24. , 'sithic' , .true. , .false., 'daily' , '' , '' , '' + bn_h_s = 'amm12_bdyT_ice' , 24. , 'snthic' , .true. , .false., 'daily' , '' , '' , '' + bn_t_i = 'NOT USED' , 24. , 'sitemp' , .true. , .false., 'daily' , '' , '' , '' + bn_t_s = 'NOT USED' , 24. , 'sntemp' , .true. , .false., 'daily' , '' , '' , '' + bn_tsu = 'NOT USED' , 24. , 'sittop' , .true. , .false., 'daily' , '' , '' , '' + bn_s_i = 'NOT USED' , 24. , 'sisalt' , .true. , .false., 'daily' , '' , '' , '' + ! melt ponds (be careful, bn_aip is the pond concentration (not fraction), so it differs from rn_iceapnd) + bn_aip = 'NOT USED' , 24. , 'siapnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hip = 'NOT USED' , 24. , 'sihpnd' , .true. , .false., 'daily' , '' , '' , '' + bn_hil = 'NOT USED' , 24. , 'sihlid' , .true. , .false., 'daily' , '' , '' , '' + ! if bn_t_i etc are "not used", then define arbitrary temperatures and salinity and ponds + rn_ice_tem = 270. ! arbitrary temperature of incoming sea ice + rn_ice_sal = 10. ! -- salinity -- + rn_ice_age = 30. ! -- age -- + rn_ice_apnd = 0.2 ! -- pond fraction = a_ip/a_i -- + rn_ice_hpnd = 0.05 ! -- pond depth -- + rn_ice_hlid = 0.0 ! -- pond lid depth -- +/ +!----------------------------------------------------------------------- +&nambdy_tide ! tidal forcing at open boundaries (default: OFF) +!----------------------------------------------------------------------- + filtide = 'bdydta/amm12_bdytide_' ! file name root of tidal forcing files + ln_bdytide_2ddta = .false. ! + ln_bdytide_conj = .false. ! +/ + +!!====================================================================== +!! *** 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_drg_OFF = .false. ! free-slip : Cd = 0 (F => fill namdrg_bot + ln_lin = .false. ! linear drag: Cd = Cd0 Uc0 & namdrg_top) + ln_non_lin = .false. ! non-linear drag: Cd = Cd0 |U| + ln_loglayer = .false. ! logarithmic drag: Cd = vkarmn/log(z/z0) |U| + ! + ln_drgimp = .true. ! implicit top/bottom friction flag + ln_drgice_imp = .false. ! implicit ice-ocean drag +/ +!----------------------------------------------------------------------- +&namdrg_top ! TOP friction (ln_drg_OFF =F & ln_isfcav=T) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.0e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&namdrg_bot ! BOTTOM friction (ln_drg_OFF =F) +!----------------------------------------------------------------------- + rn_Cd0 = 1.e-3 ! drag coefficient [-] + rn_Uc0 = 0.4 ! ref. velocity [m/s] (linear drag=Cd0*Uc0) + rn_Cdmax = 0.1 ! drag value maximum [-] (logarithmic drag) + rn_ke0 = 2.5e-3 ! background kinetic energy [m2/s2] (non-linear cases) + rn_z0 = 3.e-3 ! roughness [m] (ln_loglayer=T) + ln_boost = .false. ! =T regional boost of Cd0 ; =F constant + rn_boost = 50. ! local boost factor [-] +/ +!----------------------------------------------------------------------- +&nambbc ! bottom temperature boundary condition (default: OFF) +!----------------------------------------------------------------------- + ln_trabbc = .false. ! Apply a geothermal heating at the ocean bottom + nn_geoflx = 2 ! geothermal heat flux: = 1 constant flux + ! ! = 2 read variable flux [mW/m2] + rn_geoflx_cst = 86.4e-3 ! Constant value of geothermal heat 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 = .false. ! 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_teos10 = .true. ! = Use TEOS-10 + ln_eos80 = .false. ! = Use EOS80 + ln_seos = .false. ! = Use S-EOS (simplified Eq.) + ! + ! ! S-EOS coefficients (ln_seos=T): + ! ! rd(T,S,Z)*rau0 = -a0*(1+.5*lambda*dT+mu*Z+nu*dS)*dT+b0*dS + rn_a0 = 1.6550e-1 ! thermal expension coefficient + rn_b0 = 7.6554e-1 ! saline expension coefficient + rn_lambda1 = 5.9520e-2 ! cabbeling coeff in T^2 (=0 for linear eos) + rn_lambda2 = 7.4914e-4 ! cabbeling coeff in S^2 (=0 for linear eos) + rn_mu1 = 1.4970e-4 ! thermobaric coeff. in T (=0 for linear eos) + rn_mu2 = 1.1090e-5 ! thermobaric coeff. in S (=0 for linear eos) + rn_nu = 2.4341e-3 ! cabbeling coeff in T*S (=0 for linear eos) +/ +!----------------------------------------------------------------------- +&namtra_adv ! advection scheme for tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_traadv_OFF = .false. ! No tracer advection + ln_traadv_cen = .false. ! 2nd order centered scheme + nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_traadv_fct = .false. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + ln_traadv_mus = .false. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths + ln_traadv_ubs = .false. ! UBS scheme + nn_ubs_v = 2 ! =2 , vertical 2nd order FCT / COMPACT 4th order + ln_traadv_qck = .false. ! QUICKEST scheme +/ +!----------------------------------------------------------------------- +&namtra_ldf ! lateral diffusion scheme for tracers (default: NO selection) +!----------------------------------------------------------------------- + ! ! Operator type: + ln_traldf_OFF = .false. ! No explicit diffusion + ln_traldf_lap = .false. ! laplacian operator + ln_traldf_blp = .false. ! bilaplacian operator + ! + ! ! Direction of action: + ln_traldf_lev = .false. ! iso-level + ln_traldf_hor = .false. ! horizontal (geopotential) + ln_traldf_iso = .false. ! iso-neutral (standard operator) + ln_traldf_triad = .false. ! iso-neutral (triad operator) + ! + ! ! iso-neutral options: + ln_traldf_msc = .false. ! Method of Stabilizing Correction (both operators) + rn_slpmax = 0.01 ! slope limit (both operators) + ln_triad_iso = .false. ! pure horizontal mixing in ML (triad only) + rn_sw_triad = 1 ! =1 switching triad ; =0 all 4 triads used (triad only) + ln_botmix_triad = .false. ! lateral mixing on bottom (triad only) + ! + ! ! Coefficients: + nn_aht_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_diffusivity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! = 31 F(i,j,k,t)=F(local velocity and grid-spacing) + ! ! time invariant coefficients: aht0 = 1/2 Ud*Ld (lap case) + ! ! or = 1/12 Ud*Ld^3 (blp case) + rn_Ud = 0.01 ! 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 = .false. ! (T) use the Mixed Layer Eddy (MLE) parameterisation + rn_ce = 0.06 ! magnitude of the MLE (typical value: 0.06 to 0.08) + nn_mle = 1 ! MLE type: =0 standard Fox-Kemper ; =1 new formulation + rn_lf = 5.e+3 ! typical scale of mixed layer front (meters) (case rn_mle=0) + rn_time = 172800. ! time scale for mixing momentum across the mixed layer (seconds) (case rn_mle=0) + rn_lat = 20. ! reference latitude (degrees) of MLE coef. (case rn_mle=1) + nn_mld_uv = 0 ! space interpolation of MLD at u- & v-pts (0=min,1=averaged,2=max) + nn_conv = 0 ! =1 no MLE in case of convection ; =0 always MLE + rn_rho_c_mle = 0.01 ! delta rho criterion used to calculate MLD for FK +/ +!----------------------------------------------------------------------- +&namtra_eiv ! eddy induced velocity param. (default: OFF) +!----------------------------------------------------------------------- + ln_ldfeiv = .false. ! use eddy induced velocity parameterization + ! + ! ! Coefficients: + nn_aei_ijk_t = 0 ! space/time variation of eddy coefficient: + ! ! =-20 (=-30) read in eddy_induced_velocity_2D.nc (..._3D.nc) file + ! ! = 0 constant + ! ! = 10 F(k) =ldf_c1d + ! ! = 20 F(i,j) =ldf_c2d + ! ! = 21 F(i,j,t) =Treguier et al. JPO 1997 formulation + ! ! = 30 F(i,j,k) =ldf_c2d * ldf_c1d + ! ! time invariant coefficients: aei0 = 1/2 Ue*Le + rn_Ue = 0.02 ! 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 =.false. ! diagnose eiv stream function and velocities +/ +!----------------------------------------------------------------------- +&namtra_dmp ! tracer: T & S newtonian damping (default: OFF) +!----------------------------------------------------------------------- + ln_tradmp = .false. ! add a damping term (using resto.nc coef.) + nn_zdmp = 0 ! vertical shape =0 damping throughout the water column + ! ! =1 no damping in the mixing layer (kz criteria) + ! ! =2 no damping in the mixed layer (rho crieria) + cn_resto = 'resto.nc' ! Name of file containing restoration coeff. field (use dmp_tools to create this) +/ + +!!====================================================================== +!! *** 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) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nam_vvl ! vertical coordinate options (default: z-star) +!----------------------------------------------------------------------- + ln_vvl_zstar = .true. ! z-star vertical coordinate + ln_vvl_ztilde = .false. ! z-tilde vertical coordinate: only high frequency variations + ln_vvl_layer = .false. ! full layer vertical coordinate + ln_vvl_ztilde_as_zstar = .false. ! ztilde vertical coordinate emulating zstar + ln_vvl_zstar_at_eqtor = .false. ! ztilde near the equator + rn_ahe3 = 0.0 ! thickness diffusion coefficient + rn_rst_e3t = 30.0 ! ztilde to zstar restoration timescale [days] + rn_lf_cutoff = 5.0 ! cutoff frequency for low-pass filter [days] + rn_zdef_max = 0.9 ! maximum fractional e3t deformation + ln_vvl_dbg = .true. ! debug prints (T/F) +/ +!----------------------------------------------------------------------- +&namdyn_adv ! formulation of the momentum advection (default: NO selection) +!----------------------------------------------------------------------- + ln_dynadv_OFF = .false. ! linear dynamics (no momentum advection) + ln_dynadv_vec = .false. ! vector form - 2nd centered scheme + nn_dynkeg = 0 ! grad(KE) scheme: =0 C2 ; =1 Hollingsworth correction + ln_dynadv_cen2 = .false. ! flux form - 2nd order centered scheme + ln_dynadv_ubs = .false. ! flux form - 3rd order UBS scheme +/ +!----------------------------------------------------------------------- +&namdyn_vor ! Vorticity / Coriolis scheme (default: NO selection) +!----------------------------------------------------------------------- + ln_dynvor_ene = .false. ! energy conserving scheme + ln_dynvor_ens = .false. ! enstrophy conserving scheme + ln_dynvor_mix = .false. ! mixed scheme + ln_dynvor_enT = .false. ! energy conserving scheme (T-point) + ln_dynvor_eeT = .false. ! energy conserving scheme (een using e3t) + ln_dynvor_een = .false. ! energy & enstrophy scheme + nn_een_e3f = 0 ! =0 e3f = mi(mj(e3t))/4 + ! ! =1 e3f = mi(mj(e3t))/mi(mj( tmask)) + ln_dynvor_msk = .false. ! vorticity multiplied by fmask (=T) ==>>> PLEASE DO NOT ACTIVATE + ! ! (f-point vorticity schemes only) +/ +!----------------------------------------------------------------------- +&namdyn_hpg ! Hydrostatic pressure gradient option (default: NO selection) +!----------------------------------------------------------------------- + ln_hpg_zco = .false. ! z-coordinate - full steps + ln_hpg_zps = .false. ! z-coordinate - partial steps (interpolation) + ln_hpg_sco = .false. ! s-coordinate (standard jacobian formulation) + ln_hpg_isf = .false. ! s-coordinate (sco ) adapted to isf + ln_hpg_djc = .false. ! s-coordinate (Density Jacobian with Cubic polynomial) + ln_hpg_prj = .false. ! s-coordinate (Pressure Jacobian scheme) +/ +!----------------------------------------------------------------------- +&namdyn_spg ! surface pressure gradient (default: NO selection) +!----------------------------------------------------------------------- + ln_dynspg_exp = .false. ! explicit free surface + ln_dynspg_ts = .false. ! split-explicit free surface + ln_bt_fw = .true. ! Forward integration of barotropic Eqs. + ln_bt_av = .true. ! Time filtering of barotropic variables + nn_bt_flt = 1 ! Time filter choice = 0 None + ! ! = 1 Boxcar over nn_baro sub-steps + ! ! = 2 Boxcar over 2*nn_baro " " + ln_bt_auto = .true. ! Number of sub-step defined from: + rn_bt_cmax = 0.8 ! =T : the Maximum Courant Number allowed + nn_baro = 30 ! =F : the number of sub-step in rn_rdt seconds + rn_bt_alpha = 0. ! Temporal diffusion parameter (if ln_bt_av=F) +/ +!----------------------------------------------------------------------- +&namdyn_ldf ! lateral diffusion on momentum (default: NO selection) +!----------------------------------------------------------------------- + ! ! Type of the operator : + ln_dynldf_OFF = .false. ! No operator (i.e. no explicit diffusion) + ln_dynldf_lap = .false. ! laplacian operator + ln_dynldf_blp = .false. ! bilaplacian operator + ! ! Direction of action : + ln_dynldf_lev = .false. ! iso-level + ln_dynldf_hor = .false. ! horizontal (geopotential) + ln_dynldf_iso = .false. ! iso-neutral (lap only) + ! ! Coefficient + nn_ahm_ijk_t = 0 ! space/time variation of eddy coefficient : + ! ! =-30 read in eddy_viscosity_3D.nc file + ! ! =-20 read in eddy_viscosity_2D.nc file + ! ! = 0 constant + ! ! = 10 F(k)=c1d + ! ! = 20 F(i,j)=F(grid spacing)=c2d + ! ! = 30 F(i,j,k)=c2d*c1d + ! ! = 31 F(i,j,k)=F(grid spacing and local velocity) + ! ! = 32 F(i,j,k)=F(local gridscale and deformation rate) + ! ! time invariant coefficients : ahm = 1/2 Uv*Lv (lap case) + ! ! or = 1/12 Uv*Lv^3 (blp case) + rn_Uv = 0.1 ! lateral viscous velocity [m/s] (nn_ahm_ijk_t= 0, 10, 20, 30) + rn_Lv = 10.e+3 ! lateral viscous length [m] (nn_ahm_ijk_t= 0, 10) + ! ! Smagorinsky settings (nn_ahm_ijk_t= 32) : + rn_csmc = 3.5 ! Smagorinsky constant of proportionality + rn_minfac = 1.0 ! multiplier of theorectical lower limit + rn_maxfac = 1.0 ! multiplier of theorectical upper limit + ! ! iso-neutral laplacian operator (ln_dynldf_iso=T) : + rn_ahm_b = 0.0 ! background eddy viscosity [m2/s] +/ +!----------------------------------------------------------------------- +&namdta_dyn ! offline ocean input files (OFF_SRC only) +!----------------------------------------------------------------------- + ln_dynrnf = .false. ! runoffs option enabled (T) or not (F) + ln_dynrnf_depth = .false. ! runoffs is spread in vertical (T) or not (F) +! fwbcorr = 3.786e-06 ! annual global mean of empmr for ssh correction + + cn_dir = './' ! root directory for the ocean 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 = 'dyna_grid_T' , 120. , 'votemper' , .true. , .true. , 'yearly' , '' , '' , '' + sn_sal = 'dyna_grid_T' , 120. , 'vosaline' , .true. , .true. , 'yearly' , '' , '' , '' + sn_mld = 'dyna_grid_T' , 120. , 'somixhgt' , .true. , .true. , 'yearly' , '' , '' , '' + sn_emp = 'dyna_grid_T' , 120. , 'sowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_fmf = 'dyna_grid_T' , 120. , 'iowaflup' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ice = 'dyna_grid_T' , 120. , 'soicecov' , .true. , .true. , 'yearly' , '' , '' , '' + sn_qsr = 'dyna_grid_T' , 120. , 'soshfldo' , .true. , .true. , 'yearly' , '' , '' , '' + sn_wnd = 'dyna_grid_T' , 120. , 'sowindsp' , .true. , .true. , 'yearly' , '' , '' , '' + sn_uwd = 'dyna_grid_U' , 120. , 'uocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_vwd = 'dyna_grid_V' , 120. , 'vocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_wwd = 'dyna_grid_W' , 120. , 'wocetr_eff', .true. , .true. , 'yearly' , '' , '' , '' + sn_avt = 'dyna_grid_W' , 120. , 'voddmavs' , .true. , .true. , 'yearly' , '' , '' , '' + sn_ubl = 'dyna_grid_U' , 120. , 'sobblcox' , .true. , .true. , 'yearly' , '' , '' , '' + sn_vbl = 'dyna_grid_V' , 120. , 'sobblcoy' , .true. , .true. , 'yearly' , '' , '' , '' +/ + +!!====================================================================== +!! 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) +!----------------------------------------------------------------------- + ! ! adaptive-implicit vertical advection + ln_zad_Aimp = .false. ! Courant number dependent scheme (Shchepetkin 2015) + ! + ! ! type of vertical closure (required) + ln_zdfcst = .false. ! constant mixing + ln_zdfric = .false. ! local Richardson dependent formulation (T => fill namzdf_ric) + ln_zdftke = .false. ! Turbulent Kinetic Energy closure (T => fill namzdf_tke) + ln_zdfgls = .false. ! Generic Length Scale closure (T => fill namzdf_gls) + ln_zdfosm = .false. ! OSMOSIS BL closure (T => fill namzdf_osm) + ! + ! ! convection + ln_zdfevd = .false. ! enhanced vertical diffusion + nn_evdm = 0 ! apply on tracer (=0) or on tracer and momentum (=1) + rn_evd = 100. ! mixing coefficient [m2/s] + ln_zdfnpc = .false. ! Non-Penetrative Convective algorithm + nn_npc = 1 ! frequency of application of npc + nn_npcp = 365 ! npc control print frequency + ! + ln_zdfddm = .false. ! double diffusive mixing + rn_avts = 1.e-4 ! maximum avs (vertical mixing on salinity) + rn_hsbfr = 1.6 ! heat/salt buoyancy flux ratio + ! + ! ! gravity wave-driven vertical mixing + ln_zdfiwm = .false. ! internal wave-induced mixing (T => fill namzdf_iwm) + ln_zdfswm = .false. ! surface wave-induced mixing (T => ln_wave=ln_sdw=T ) + ! + ! ! 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 = 0 ! horizontal shape for avtb (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namzdf_ric ! richardson number dependent vertical diffusion (ln_zdfric =T) +!----------------------------------------------------------------------- + rn_avmri = 100.e-4 ! maximum value of the vertical viscosity + rn_alp = 5. ! coefficient of the parameterization + nn_ric = 2 ! coefficient of the parameterization + ln_mldw = .false. ! enhanced mixing in the Ekman layer + rn_ekmfc = 0.7 ! Factor in the Ekman depth Equation + rn_mldmin = 1.0 ! minimum allowable mixed-layer depth estimate (m) + rn_mldmax = 1000.0 ! maximum allowable mixed-layer depth estimate (m) + rn_wtmix = 10.0 ! vertical eddy viscosity coeff [m2/s] in the mixed-layer + rn_wvmix = 10.0 ! vertical eddy diffusion coeff [m2/s] in the mixed-layer +/ +!----------------------------------------------------------------------- +&namzdf_tke ! turbulent eddy kinetic dependent vertical diffusion (ln_zdftke =T) +!----------------------------------------------------------------------- + rn_ediff = 0.1 ! coef. for vertical eddy coef. (avt=rn_ediff*mxl*sqrt(e) ) + rn_ediss = 0.7 ! coef. of the Kolmogoroff dissipation + rn_ebb = 67.83 ! coef. of the surface input of tke (=67.83 suggested when ln_mxl0=T) + rn_emin = 1.e-6 ! minimum value of tke [m2/s2] + rn_emin0 = 1.e-4 ! surface minimum value of tke [m2/s2] + rn_bshear = 1.e-20 ! background shear (>0) currently a numerical threshold (do not change it) + nn_pdl = 1 ! Prandtl number function of richarson number (=1, avt=pdl(Ri)*avm) or not (=0, avt=avm) + 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 + ln_mxl0 = .true. ! surface mixing length scale = F(wind stress) (T) or not (F) + nn_mxlice = 2 ! type of scaling under sea-ice + ! = 0 no scaling under sea-ice + ! = 1 scaling with constant sea-ice thickness + ! = 2 scaling with mean sea-ice thickness ( only with SI3 sea-ice model ) + ! = 3 scaling with maximum sea-ice thickness + rn_mxlice = 10. ! max constant ice thickness value when scaling under sea-ice ( nn_mxlice=1) + rn_mxl0 = 0.04 ! surface buoyancy lenght scale minimum value + ln_lc = .true. ! Langmuir cell parameterisation (Axell 2002) + rn_lc = 0.15 ! coef. associated to Langmuir cells + 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) + rn_efr = 0.05 ! fraction of surface tke value which penetrates below the ML (nn_etau=1 or 2) + nn_htau = 1 ! type of exponential decrease of tke penetration below the ML + ! = 0 constant 10 m length scale + ! = 1 0.5m at the equator to 30m poleward of 40 degrees + nn_eice = 1 ! attenutaion of langmuir & surface wave breaking under ice + ! ! = 0 no impact of ice cover on langmuir & surface wave breaking + ! ! = 1 weigthed by 1-TANH(10*fr_i) + ! ! = 2 weighted by 1-fr_i + ! ! = 3 weighted by 1-MIN(1,4*fr_i) +/ +!----------------------------------------------------------------------- +&namzdf_gls ! GLS vertical diffusion (ln_zdfgls =T) +!----------------------------------------------------------------------- + rn_emin = 1.e-7 ! minimum value of e [m2/s2] + rn_epsmin = 1.e-12 ! minimum value of eps [m2/s3] + ln_length_lim = .true. ! limit on the dissipation rate under stable stratification (Galperin et al., 1988) + rn_clim_galp = 0.267 ! galperin limit + ln_sigpsi = .true. ! Activate or not Burchard 2001 mods on psi schmidt number in the wb case + rn_crban = 100. ! Craig and Banner 1994 constant for wb tke flux + rn_charn = 70000. ! Charnock constant for wb induced roughness length + rn_hsro = 0.02 ! Minimum surface roughness + rn_hsri = 0.03 ! Ice-ocean roughness + rn_frac_hs = 1.3 ! Fraction of wave height as roughness (if nn_z0_met>1) + nn_z0_met = 2 ! Method for surface roughness computation (0/1/2/3) + ! ! = 3 requires ln_wave=T + nn_z0_ice = 1 ! attenutaion of surface wave breaking under ice + ! ! = 0 no impact of ice cover + ! ! = 1 roughness uses rn_hsri and is weigthed by 1-TANH(10*fr_i) + ! ! = 2 roughness uses rn_hsri and is weighted by 1-fr_i + ! ! = 3 roughness uses rn_hsri and is weighted by 1-MIN(1,4*fr_i) + nn_bc_surf = 1 ! surface condition (0/1=Dir/Neum) + nn_bc_bot = 1 ! bottom condition (0/1=Dir/Neum) + nn_stab_func = 2 ! stability function (0=Galp, 1= KC94, 2=CanutoA, 3=CanutoB) + nn_clos = 1 ! predefined closure type (0=MY82, 1=k-eps, 2=k-w, 3=Gen) +/ +!----------------------------------------------------------------------- +&namzdf_osm ! OSM vertical diffusion (ln_zdfosm =T) +!----------------------------------------------------------------------- + ln_use_osm_la = .false. ! Use namelist rn_osm_la + rn_osm_la = 0.3 ! Turbulent Langmuir number + rn_osm_dstokes = 5. ! Depth scale of Stokes drift (m) + nn_ave = 0 ! choice of horizontal averaging on avt, avmu, avmv + ln_dia_osm = .true. ! output OSMOSIS-OBL variables + rn_osm_hbl0 = 10. ! initial hbl value + ln_kpprimix = .true. ! Use KPP-style Ri# mixing below BL + rn_riinfty = 0.7 ! Highest local Ri_g permitting shear instability + rn_difri = 0.005 ! max Ri# diffusivity at Ri_g = 0 (m^2/s) + ln_convmix = .true. ! Use convective instability mixing below BL + rn_difconv = 1. ! diffusivity when unstable below BL (m2/s) + nn_osm_wave = 0 ! Method used to calculate Stokes drift + ! ! = 2: Use ECMWF wave fields + ! ! = 1: Pierson Moskowitz wave spectrum + ! ! = 0: Constant La# = 0.3 +/ +!----------------------------------------------------------------------- +&namzdf_iwm ! internal wave-driven mixing parameterization (ln_zdfiwm =T) +!----------------------------------------------------------------------- + nn_zpyc = 1 ! pycnocline-intensified dissipation scales as N (=1) or N^2 (=2) + ln_mevar = .true. ! variable (T) or constant (F) mixing efficiency + ln_tsdiff = .true. ! account for differential T/S mixing (T) or not (F) +/ + +!!====================================================================== +!! *** Diagnostics namelists *** !! +!! !! +!! namtrd dynamics and/or tracer trends (default: OFF) +!! namptr Poleward Transport Diagnostics (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_diaharm Harmonic analysis of tidal constituents (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") +!!====================================================================== +! +!----------------------------------------------------------------------- +&namtrd ! trend diagnostics (default: OFF) +!----------------------------------------------------------------------- + ln_glo_trd = .false. ! (T) global domain averaged diag for T, T^2, KE, and PE + ln_dyn_trd = .false. ! (T) 3D momentum trend output + ln_dyn_mxl = .false. ! (T) 2D momentum trends averaged over the mixed layer (not coded yet) + ln_vor_trd = .false. ! (T) 2D barotropic vorticity trends (not coded yet) + ln_KE_trd = .false. ! (T) 3D Kinetic Energy trends + ln_PE_trd = .false. ! (T) 3D Potential Energy trends + ln_tra_trd = .false. ! (T) 3D tracer trend output + ln_tra_mxl = .false. ! (T) 2D tracer trends averaged over the mixed layer (not coded yet) + nn_trd = 365 ! print frequency (ln_glo_trd=T) (unit=time step) +/ +!!gm nn_ctls = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) +!!gm cn_trdrst_in = "restart_mld" ! suffix of ocean restart name (input) +!!gm cn_trdrst_out = "restart_mld" ! suffix of ocean restart name (output) +!!gm ln_trdmld_restart = .false. ! restart for ML diagnostics +!!gm ln_trdmld_instant = .false. ! flag to diagnose trends of instantantaneous or mean ML T/S +!!gm +!----------------------------------------------------------------------- +&namptr ! Poleward Transport Diagnostic (default: OFF) +!----------------------------------------------------------------------- + ln_diaptr = .false. ! Poleward heat and salt transport (T) or not (F) + ln_subbas = .false. ! Atlantic/Pacific/Indian basins computation (T) or not +/ +!----------------------------------------------------------------------- +&namhsb ! Heat and salt budgets (default: OFF) +!----------------------------------------------------------------------- + ln_diahsb = .false. ! output the heat and salt budgets (T) or not (F) +/ +!----------------------------------------------------------------------- +&namdiu ! Cool skin and warm layer models (default: OFF) +!----------------------------------------------------------------------- + ln_diurnal = .false. ! + ln_diurnal_only = .false. ! +/ +!----------------------------------------------------------------------- +&namflo ! float parameters (default: OFF) +!----------------------------------------------------------------------- + ln_floats = .false. ! activate floats or not + jpnfl = 1 ! total number of floats during the run + jpnnewflo = 0 ! number of floats for the restart + ln_rstflo = .false. ! float restart (T) or not (F) + nn_writefl = 75 ! frequency of writing in float output file + nn_stockfl = 5475 ! frequency of creation of the float restart file + ln_argo = .false. ! Argo type floats (stay at the surface each 10 days) + ln_flork4 = .false. ! trajectories computed with a 4th order Runge-Kutta (T) + ! ! or computed with Blanke' scheme (F) + ln_ariane = .true. ! Input with Ariane tool convention(T) + ln_flo_ascii= .true. ! Output with Ariane tool netcdf convention(F) or ascii file (T) +/ +!----------------------------------------------------------------------- +&nam_diaharm ! Harmonic analysis of tidal constituents (default: OFF) +!----------------------------------------------------------------------- + ln_diaharm = .false. ! Choose tidal harmonic output or not + nit000_han = 1 ! First time step used for harmonic analysis + nitend_han = 75 ! Last time step used for harmonic analysis + nstep_han = 15 ! Time step frequency for harmonic analysis + tname(1) = 'M2' ! Name of tidal constituents + tname(2) = 'K1' ! --- +/ +!----------------------------------------------------------------------- +&nam_diadct ! transports through some sections (default: OFF) +!----------------------------------------------------------------------- + ln_diadct = .false. ! Calculate transport thru sections or not + nn_dct = 15 ! time step frequency for transports computing + nn_dctwri = 15 ! time step frequency for transports writing + nn_secdebug = 112 ! 0 : no section to debug + ! ! -1 : debug all section + ! ! 0 < n : debug section number n +/ +!----------------------------------------------------------------------- +&nam_dia25h ! 25h Mean Output (default: OFF) +!----------------------------------------------------------------------- + ln_dia25h = .false. ! Choose 25h mean output or not +/ +!----------------------------------------------------------------------- +&namnc4 ! netcdf4 chunking and compression settings ("key_netcdf4") +!----------------------------------------------------------------------- + nn_nchunks_i = 4 ! number of chunks in i-dimension + nn_nchunks_j = 4 ! number of chunks in j-dimension + nn_nchunks_k = 31 ! number of chunks in k-dimension + ! ! setting nn_nchunks_k = jpk will give a chunk size of 1 in the vertical which + ! ! is optimal for postprocessing which works exclusively with horizontal slabs + ln_nc4zip = .true. ! (T) use netcdf4 chunking and compression + ! ! (F) ignore chunking information and produce netcdf3-compatible files +/ + +!!====================================================================== +!! *** Observation & Assimilation *** !! +!! !! +!! namobs observation and model comparison (default: OFF) +!! nam_asminc assimilation increments ('key_asminc') +!!====================================================================== +! +!----------------------------------------------------------------------- +&namobs ! observation usage switch (default: OFF) +!----------------------------------------------------------------------- + ln_diaobs = .false. ! Logical switch for the observation operator + ! + ln_t3d = .false. ! Logical switch for T profile observations + ln_s3d = .false. ! Logical switch for S profile observations + ln_sla = .false. ! Logical switch for SLA observations + ln_sst = .false. ! Logical switch for SST observations + ln_sss = .false. ! Logical swithc for SSS observations + ln_sic = .false. ! Logical switch for Sea Ice observations + ln_vel3d = .false. ! Logical switch for velocity observations + ln_altbias = .false. ! Logical switch for altimeter bias correction + ln_sstbias = .false. ! Logical switch for SST bias correction + ln_nea = .false. ! Logical switch for rejection of observations near land + ln_grid_global = .true. ! Logical switch for global distribution of observations + ln_grid_search_lookup = .false. ! Logical switch for obs grid search w/lookup table + ln_ignmis = .true. ! Logical switch for ignoring missing files + ln_s_at_t = .false. ! Logical switch for computing model S at T obs if not there + ln_sstnight = .false. ! Logical switch for calculating night-time average for SST obs + ln_bound_reject = .false. ! Logical to remove obs near boundaries in LAMs. + ln_sla_fp_indegs = .true. ! Logical for SLA: T=> averaging footprint is in degrees, F=> in metres + ln_sst_fp_indegs = .true. ! Logical for SST: T=> averaging footprint is in degrees, F=> in metres + ln_sss_fp_indegs = .true. ! Logical for SSS: T=> averaging footprint is in degrees, F=> in metres + ln_sic_fp_indegs = .true. ! Logical for SIC: T=> averaging footprint is in degrees, F=> in metres +! All of the *files* variables below are arrays. Use namelist_cfg to add more files + cn_profbfiles = 'profiles_01.nc' ! Profile feedback input observation file names + cn_slafbfiles = 'sla_01.nc' ! SLA feedback input observation file names + cn_sstfbfiles = 'sst_01.nc' ! SST feedback input observation file names + cn_sssfbfiles = 'sss_01.nc' ! SSS feedback input observation file names + cn_sicfbfiles = 'sic_01.nc' ! SIC feedback input observation file names + cn_velfbfiles = 'vel_01.nc' ! Velocity feedback input observation file names + cn_altbiasfile = 'altbias.nc' ! Altimeter bias input file name + cn_sstbiasfiles = 'sstbias.nc' ! SST bias input file name + cn_gridsearchfile ='gridsearch.nc' ! Grid search file name + rn_gridsearchres = 0.5 ! Grid search resolution + rn_mdtcorr = 1.61 ! MDT correction + rn_mdtcutoff = 65.0 ! MDT cutoff for computed correction + rn_dobsini = 00010101.000000 ! Initial date in window YYYYMMDD.HHMMSS + rn_dobsend = 00010102.000000 ! Final date in window YYYYMMDD.HHMMSS + rn_sla_avglamscl = 0. ! E/W diameter of SLA observation footprint (metres/degrees) + rn_sla_avgphiscl = 0. ! N/S diameter of SLA observation footprint (metres/degrees) + rn_sst_avglamscl = 0. ! E/W diameter of SST observation footprint (metres/degrees) + rn_sst_avgphiscl = 0. ! N/S diameter of SST observation footprint (metres/degrees) + rn_sss_avglamscl = 0. ! E/W diameter of SSS observation footprint (metres/degrees) + rn_sss_avgphiscl = 0. ! N/S diameter of SSS observation footprint (metres/degrees) + rn_sic_avglamscl = 0. ! E/W diameter of SIC observation footprint (metres/degrees) + rn_sic_avgphiscl = 0. ! N/S diameter of SIC observation footprint (metres/degrees) + nn_1dint = 0 ! Type of vertical interpolation method + nn_2dint = 0 ! Default horizontal interpolation method + nn_2dint_sla = 0 ! Horizontal interpolation method for SLA + nn_2dint_sst = 0 ! Horizontal interpolation method for SST + nn_2dint_sss = 0 ! Horizontal interpolation method for SSS + nn_2dint_sic = 0 ! Horizontal interpolation method for SIC + nn_msshc = 0 ! MSSH correction scheme + nn_profdavtypes = -1 ! Profile daily average types - array +/ +!----------------------------------------------------------------------- +&nam_asminc ! assimilation increments ('key_asminc') +!----------------------------------------------------------------------- + ln_bkgwri = .false. ! Logical switch for writing out background state + ln_trainc = .false. ! Logical switch for applying tracer increments + ln_dyninc = .false. ! Logical switch for applying velocity increments + ln_sshinc = .false. ! Logical switch for applying SSH increments + ln_asmdin = .false. ! Logical switch for Direct Initialization (DI) + ln_asmiau = .false. ! Logical switch for Incremental Analysis Updating (IAU) + nitbkg = 0 ! Timestep of background in [0,nitend-nit000-1] + nitdin = 0 ! Timestep of background for DI in [0,nitend-nit000-1] + nitiaustr = 1 ! Timestep of start of IAU interval in [0,nitend-nit000-1] + nitiaufin = 15 ! Timestep of end of IAU interval in [0,nitend-nit000-1] + niaufn = 0 ! Type of IAU weighting function + ln_salfix = .false. ! Logical switch for ensuring that the sa > salfixmin + salfixmin = -9999 ! Minimum salinity after applying the increments + nn_divdmp = 0 ! Number of iterations of divergence damping operator +/ + +!!====================================================================== +!! *** Miscellaneous namelists *** !! +!! !! +!! nammpp Massively Parallel Processing ("key_mpp_mpi") +!! namctl Control prints (default: OFF) +!! namsto Stochastic parametrization of EOS (default: OFF) +!!====================================================================== +! +!----------------------------------------------------------------------- +&nammpp ! Massively Parallel Processing ("key_mpp_mpi") +!----------------------------------------------------------------------- + ln_listonly = .false. ! do nothing else than listing the best domain decompositions (with land domains suppression) + ! ! if T: the largest number of cores tested is defined by max(mppsize, jpni*jpnj) + ln_nnogather = .true. ! activate code to avoid mpi_allgather use at the northfold + jpni = 0 ! number of processors following i (set automatically if < 1), see also ln_listonly = T + jpnj = 0 ! number of processors following j (set automatically if < 1), see also ln_listonly = T +/ +!----------------------------------------------------------------------- +&namctl ! Control prints (default: OFF) +!----------------------------------------------------------------------- + ln_ctl = .FALSE. ! Toggle all report printing on/off (T/F); Ignored if sn_cfctl%l_config is T + sn_cfctl%l_config = .TRUE. ! IF .true. then control which reports are written with the following + sn_cfctl%l_runstat = .FALSE. ! switches and which areas produce reports with the proc integer settings. + sn_cfctl%l_trcstat = .FALSE. ! The default settings for the proc integers should ensure + sn_cfctl%l_oceout = .FALSE. ! that all areas report. + sn_cfctl%l_layout = .FALSE. ! + sn_cfctl%l_mppout = .FALSE. ! + sn_cfctl%l_mpptop = .FALSE. ! + sn_cfctl%procmin = 0 ! Minimum area number for reporting [default:0] + sn_cfctl%procmax = 1000000 ! Maximum area number for reporting [default:1000000] + sn_cfctl%procincr = 1 ! Increment for optional subsetting of areas [default:1] + sn_cfctl%ptimincr = 1 ! Timestep increment for writing time step progress info + nn_print = 0 ! level of print (0 no extra print) + nn_ictls = 0 ! start i indice of control sum (use to compare mono versus + nn_ictle = 0 ! end i indice of control sum multi processor runs + nn_jctls = 0 ! start j indice of control over a subdomain) + nn_jctle = 0 ! end j indice of control + nn_isplt = 1 ! number of processors in i-direction + nn_jsplt = 1 ! number of processors in j-direction + ln_timing = .false. ! timing by routine write out in timing.output file + ln_diacfl = .false. ! CFL diagnostics write out in cfl_diagnostics.ascii +/ +!----------------------------------------------------------------------- +&namsto ! Stochastic parametrization of EOS (default: OFF) +!----------------------------------------------------------------------- + ln_sto_eos = .false. ! stochastic equation of state + nn_sto_eos = 1 ! number of independent random walks + rn_eos_stdxy = 1.4 ! random walk horz. standard deviation (in grid points) + rn_eos_stdz = 0.7 ! random walk vert. standard deviation (in grid points) + rn_eos_tcor = 1440. ! random walk time correlation (in timesteps) + nn_eos_ord = 1 ! order of autoregressive processes + nn_eos_flt = 0 ! passes of Laplacian filter + rn_eos_lim = 2.0 ! limitation factor (default = 3.0) + ln_rststo = .false. ! start from mean parameter (F) or from restart file (T) + ln_rstseed = .true. ! read seed of RNG from restart file + cn_storst_in = "restart_sto" ! suffix of stochastic parameter restart file (input) + cn_storst_out = "restart_sto" ! suffix of stochastic parameter restart file (output) +/ diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/namelist_top_ref b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_top_ref new file mode 100644 index 0000000..49108fd --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_top_ref @@ -0,0 +1,151 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! NEMO/TOP : Reference namelist +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! - tracer run information (namtrc_run) +!! - tracer definition (namtrc ) +!! - tracer data initialisation (namtrc_dta) +!! - tracer advection (namtrc_adv) +!! - tracer lateral diffusion (namtrc_ldf) +!! - tracer vertical physics (namtrc_zdf) +!! - tracer newtonian damping (namtrc_dmp) +!! - dynamical tracer trends (namtrc_trd) +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +&namtrc_run ! run information +!----------------------------------------------------------------------- + nn_dttrc = 1 ! time step frequency for passive sn_tracers + ln_top_euler = .false. ! use Euler time-stepping for TOP + ln_rsttr = .false. ! start from a restart file (T) or not (F) + nn_rsttr = 0 ! restart control = 0 initial time step is not compared to the restart file value + ! = 1 do not use the value in the restart file + ! = 2 calendar parameters read in the restart file + cn_trcrst_in = "restart_trc" ! suffix of pass. sn_tracer restart name (input) + cn_trcrst_indir = "." ! directory from which to read input passive tracer restarts + cn_trcrst_out = "restart_trc" ! suffix of pass. sn_tracer restart name (output) + cn_trcrst_outdir = "." ! directory to which to write output passive tracer restarts +/ +!----------------------------------------------------------------------- +&namtrc ! tracers definition +!----------------------------------------------------------------------- + jp_bgc = 0 ! Number of passive tracers of the BGC model + ! + ln_pisces = .false. ! Run PISCES BGC model + ln_my_trc = .false. ! Run MY_TRC BGC model + ln_age = .false. ! Run the sea water age tracer + ln_cfc11 = .false. ! Run the CFC11 passive tracer + ln_cfc12 = .false. ! Run the CFC12 passive tracer + ln_sf6 = .false. ! Run the SF6 passive tracer + ln_c14 = .false. ! Run the Radiocarbon passive tracer + ! + ln_trcdta = .false. ! Initialisation from data input file (T) or not (F) + ln_trcdmp = .false. ! add a damping termn (T) or not (F) + ln_trcdmp_clo = .false. ! damping term (T) or not (F) on closed seas + ! + jp_dia3d = 0 ! Number of 3D diagnostic variables + jp_dia2d = 0 ! Number of 2D diagnostic variables + !_____________!___________!_________________________________________!____________!________________! + ! ! name ! title of the field ! units ! init from file ! +! sn_tracer(1) = 'tracer ', 'Tracer Concentration ', ' - ' , .false. +/ +!----------------------------------------------------------------------- +&namage ! AGE +!----------------------------------------------------------------------- + rn_age_depth = 10 ! depth over which age tracer reset to zero + rn_age_kill_rate = -0.000138888 ! = -1/7200 recip of relaxation timescale (s) for age tracer shallower than age_depth +/ +!----------------------------------------------------------------------- +&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_TRC_nomask' , -12. , 'TRC' , .false. , .true. , 'yearly' , '' , '' , '' + ! + cn_dir = './' ! root directory for the location of the data files +/ +!----------------------------------------------------------------------- +&namtrc_adv ! advection scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- + ln_trcadv_OFF = .false. ! No passive tracer advection + ln_trcadv_cen = .false. ! 2nd order centered scheme + nn_cen_h = 4 ! =2/4, horizontal 2nd order CEN / 4th order CEN + nn_cen_v = 4 ! =2/4, vertical 2nd order CEN / 4th order COMPACT + ln_trcadv_fct = .false. ! FCT scheme + nn_fct_h = 2 ! =2/4, horizontal 2nd / 4th order + nn_fct_v = 2 ! =2/4, vertical 2nd / COMPACT 4th order + ln_trcadv_mus = .false. ! MUSCL scheme + ln_mus_ups = .false. ! use upstream scheme near river mouths + ln_trcadv_ubs = .false. ! UBS scheme + nn_ubs_v = 2 ! =2 , vertical 2nd order FCT + ln_trcadv_qck = .false. ! QUICKEST scheme +/ +!----------------------------------------------------------------------- +&namtrc_ldf ! lateral diffusion scheme for passive tracer (default: NO selection) +!----------------------------------------------------------------------- +! ! Type of the operator: + ln_trcldf_OFF = .false. ! No explicit diffusion + ln_trcldf_tra = .false. ! use active tracer setting + ! ! Coefficient (defined with namtra_ldf coefficient) + rn_ldf_multi = 1. ! multiplier of aht for TRC mixing coefficient + rn_fact_lap = 1. ! Equatorial enhanced zonal eddy diffusivity (lap only) +/ +!----------------------------------------------------------------------- +&namtrc_rad ! treatment of negative concentrations +!----------------------------------------------------------------------- + ln_trcrad = .true. ! artificially correct negative concentrations (T) or not (F) +/ +!----------------------------------------------------------------------- +&namtrc_snk ! Sedimentation of particles +!----------------------------------------------------------------------- + nitermax = 2 ! number of iterations for sedimentation +/ +!----------------------------------------------------------------------- +&namtrc_dmp ! passive tracer newtonian damping (ln_trcdmp=T) +!----------------------------------------------------------------------- + nn_zdmp_tr = 1 ! vertical shape =0 damping throughout the water column + ! =1 no damping in the mixing layer (kz criteria) + ! =2 no damping in the mixed layer (rho crieria) + cn_resto_tr = 'resto_tr.nc' ! create a damping.coeff NetCDF file (=1) or not (=0) +/ +!----------------------------------------------------------------------- +&namtrc_ice ! Representation of sea ice growth & melt effects +!----------------------------------------------------------------------- + nn_ice_tr = -1 ! tracer concentration in sea ice + ! =-1 (no vvl: identical cc in ice and ocean / vvl: cc_ice = 0) + ! = 0 (no vvl: cc_ice = zero / vvl: cc_ice = ) + ! = 1 prescribed to a namelist value (implemented in pisces only) +/ +!----------------------------------------------------------------------- +&namtrc_trd ! diagnostics on tracer trends ('key_trdtrc') +! or mixed-layer trends ('key_trdmld_trc') +!---------------------------------------------------------------------- + nn_trd_trc = 5475 ! time step frequency and tracers trends + nn_ctls_trc = 0 ! control surface type in mixed-layer trends (0,1 or n /seconds ; =86400. -> /day) + ln_trdmxl_trc_restart = .false. ! restart for ML diagnostics + ln_trdmxl_trc_instant = .true. ! flag to diagnose trends of instantantaneous or mean ML T/S + cn_trdrst_trc_in = 'restart_trd' ! suffix of pass. tracer trends restart name (input) + cn_trdrst_trc_out = 'restart_trd' ! suffix of pass. tracer trends restart name (output) + ln_trdtrc( 1) = .true. + ln_trdtrc( 2) = .true. + ln_trdtrc(23) = .true. +/ +!---------------------------------------------------------------------- +&namtrc_bc ! data for boundary conditions +!----------------------------------------------------------------------- + cn_dir_sbc = './' ! root directory for the location of SURFACE data files + cn_dir_cbc = './' ! root directory for the location of COASTAL data files + cn_dir_obc = './' ! root directory for the location of OPEN data files + ln_rnf_ctl = .false. ! Remove runoff dilution on tracers with absent river load + rn_bc_time = 86400. ! Time scaling factor for SBC and CBC data (seconds in a day) +/ +!---------------------------------------------------------------------- +&namtrc_bdy ! Setup of tracer boundary conditions +!----------------------------------------------------------------------- + cn_trc_dflt = 'neumann' ! OBC applied by default to all tracers + cn_trc = 'none' ! Boundary conditions used for tracers with data files (selected in namtrc) + + nn_trcdmp_bdy = 0 ! Use damping timescales defined in nambdy of namelist + ! = 0 NO damping of tracers at open boudaries + ! = 1 Only for tracers forced with external data + ! = 2 Damping applied to all tracers +/ diff --git a/NEMO_4.0.4_surge/cfgs/SHARED/namelist_trc_ref b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_trc_ref new file mode 100644 index 0000000..109393b --- /dev/null +++ b/NEMO_4.0.4_surge/cfgs/SHARED/namelist_trc_ref @@ -0,0 +1,45 @@ +!!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!! Inert tracers reference namelist +!! 1 - CFC (namcfc) +!! 2 - C14 (namc14_typ, namc14_sbc, namc14_fcg) +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +&namcfc ! CFC +!----------------------------------------------------------------------- + ndate_beg = 300101 ! datedeb1 + nyear_res = 1932 ! iannee1 + ! + ! Formatted file of annual hemisperic CFCs concentration in the atmosphere (ppt) + clname = 'CFCs_CDIAC.dat' +/ +! +!----------------------------------------------------------------------- +&namc14_typ ! C14 - type of C14 tracer, default values of C14/C and pco2 +!----------------------------------------------------------------------- + kc14typ = 0 ! Type of C14 tracer (0=equilibrium; 1=bomb transient; 2=past transient) + rc14at = 1.0 ! Default value for atmospheric C14/C (used for equil run) + pco2at = 280.0 ! Default value for atmospheric pcO2 [atm] (used for equil run) + rc14init = 0.85 ! Default value for initialization of ocean C14/C (when no restart) +/ +! +!----------------------------------------------------------------------- +&namc14_sbc ! C14 - surface BC +!----------------------------------------------------------------------- + ln_chemh = .true. ! Chemical enhancement in piston vel.: yes/no + xkwind = 0.360 ! Coefficient for gas exchange velocity + xdicsur = 2.0 ! Reference DIC surface concentration (mol/m3) +/ +! +!----------------------------------------------------------------------- +&namc14_fcg ! files & dates +! ! For Paleo-historical: specify tyrc14_beg in yr BP +! ! For Bomb: tyrc14_beg=0 +!----------------------------------------------------------------------- + cfileco2 = 'splco2.dat' ! atmospheric co2 - Bomb + cfilec14 = 'atmc14.dat' ! atmospheric c14 - Bomb + tyrc14_beg = 0.00 ! starting year of experiment - Bomb +! cfileco2 = 'ByrdEdcCO2.txt' ! atmospheric co2 - Paleo +! cfilec14 = 'intcal13.14c' ! atmospheric c14 - Paleo +! tyrc14_beg = 35000.00 ! starting year of experiment - Paleo (yr BP) +/ +! diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/entries b/NEMO_4.0.4_surge/ext/FCM/.svn/entries new file mode 100644 index 0000000..48082f7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/entries @@ -0,0 +1 @@ +12 diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/format b/NEMO_4.0.4_surge/ext/FCM/.svn/format new file mode 100644 index 0000000..48082f7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/format @@ -0,0 +1 @@ +12 diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/02/02b1cb563cac602a8148ba55888bb5f1e0cb23e9.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/02/02b1cb563cac602a8148ba55888bb5f1e0cb23e9.svn-base new file mode 100644 index 0000000..6f22252 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/02/02b1cb563cac602a8148ba55888bb5f1e0cb23e9.svn-base @@ -0,0 +1,181 @@ +! A simple function +logical function func_simple() +func_simple = .true. +end function func_simple + +! A simple function, but with less friendly end +logical function func_simple_1() +func_simple_1 = .true. +end function + +! A simple function, but with even less friendly end +logical function func_simple_2() +func_simple_2 = .true. +end + +! A pure simple function +pure logical function func_simple_pure() +func_simple_pure = .true. +end function func_simple_pure + +! A pure recursive function +recursive pure integer function func_simple_recursive_pure(i) +integer, intent(in) :: i +if (i <= 0) then + func_simple_recursive_pure = i +else + func_simple_recursive_pure = i + func_simple_recursive_pure(i - 1) +end if +end function func_simple_recursive_pure + +! An elemental simple function +elemental logical function func_simple_elemental() +func_simple_elemental = .true. +end function func_simple_elemental + +! A module with nonsense +module bar +type food +integer :: cooking_method +end type food +type organic +integer :: growing_method +end type organic +integer, parameter :: i_am_dim = 10 +end module bar + +! A module with more nonsense +module foo +use bar, only: FOOD +integer :: foo_int +contains +subroutine foo_sub(egg) +integer, parameter :: egg_dim = 10 +type(Food), intent(in) :: egg +write(*, *) egg +end subroutine foo_sub +elemental function foo_func() result(f) +integer :: f +f = 0 +end function +end module foo + +! An function with arguments and module imports +integer(selected_int_kind(0)) function func_with_use_and_args(egg, ham) +use foo +! Deliberate trailing spaces in next line +use bar, only : organic, i_am_dim +implicit none +integer, intent(in) :: egg(i_am_dim) +integer, intent(in) :: ham(i_am_dim, 2) +real bacon +! Deliberate trailing spaces in next line +type( organic ) :: tomato +func_with_use_and_args = egg(1) + ham(1, 1) +end function func_with_use_and_args + +! A function with some parameters +character(20) function func_with_parameters(egg, ham) +implicit none +character*(*), parameter :: x_param = '01234567890' +character(*), parameter :: & ! throw in some comments + y_param & + = '!&!&!&!&!&!' ! how to make life interesting +integer, parameter :: z = 20 +character(len(x_param)), intent(in) :: egg +character(len(y_param)), intent(in) :: ham +func_with_parameters = egg // ham +end function func_with_parameters + +! A function with some parameters, with a result +function func_with_parameters_1(egg, ham) result(r) +implicit none +integer, parameter :: x_param = 10 +integer z_param +parameter(z_param = 2) +real, intent(in), dimension(x_param) :: egg +integer, intent(in) :: ham +logical :: r(z_param) +r(1) = int(egg(1)) + ham > 0 +r(2) = .false. +end function func_with_parameters_1 + +! A function with a contains +character(10) function func_with_contains(mushroom, tomoato) +character(5) mushroom +character(5) tomoato +func_with_contains = func_with_contains_1() +contains +character(10) function func_with_contains_1() +func_with_contains_1 = mushroom // tomoato +end function func_with_contains_1 +end function func_with_contains + +! A function with its result declared after a local in the same statement +Function func_mix_local_and_result(egg, ham, bacon) Result(Breakfast) +Integer, Intent(in) :: egg, ham +Real, Intent(in) :: bacon +Real :: tomato, breakfast +Breakfast = real(egg) + real(ham) + bacon +End Function func_mix_local_and_result + +! A simple subroutine +subroutine sub_simple() +end subroutine sub_simple + +! A simple subroutine, with not so friendly end +subroutine sub_simple_1() +end subroutine + +! A simple subroutine, with even less friendly end +subroutine sub_simple_2() +end + +! A simple subroutine, with funny continuation +subroutine sub_simple_3() +end sub& +&routine& +& sub_simple_3 + +! A subroutine with a few contains +subroutine sub_with_contains(foo) ! " & +! Deliberate trailing spaces in next line +use Bar, only: i_am_dim +character*(len('!"&''&"!')) & ! what a mess! + foo +call sub_with_contains_first() +call sub_with_contains_second() +call sub_with_contains_third() +print*, foo +contains +subroutine sub_with_contains_first() +interface +integer function x() +end function x +end interface +end subroutine sub_with_contains_first +subroutine sub_with_contains_second() +end subroutine +subroutine sub_with_contains_third() +end subroutine +end subroutine sub_with_contains + +! A subroutine with a renamed module import +subroutine sub_with_renamed_import(i_am_dim) +use bar, only: i_am_not_dim => i_am_dim +integer, parameter :: d = 2 +complex :: i_am_dim(d) +print*, i_am_dim +end subroutine sub_with_renamed_import + +! A subroutine with an external argument +subroutine sub_with_external(proc) +external proc +call proc() +end subroutine sub_with_external + +! A subroutine with a variable named "end" +subroutine sub_with_end() +integer :: end +end = 0 +end subroutine sub_with_end diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/03/0348769b4e68e90d6731a4ee3c7a1cd806a0e320.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/03/0348769b4e68e90d6731a4ee3c7a1cd806a0e320.svn-base new file mode 100644 index 0000000..618dba8 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/03/0348769b4e68e90d6731a4ee3c7a1cd806a0e320.svn-base @@ -0,0 +1,536 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +# ------------------------------------------------------------------------------ +package Fcm::Build::Fortran; + +use Text::Balanced qw{extract_bracketed extract_delimited}; + +# Actions of this class +my %ACTION_OF = (extract_interface => \&_extract_interface); + +# Regular expressions +# Matches a variable attribute +my $RE_ATTR = qr{ + allocatable|dimension|external|intent|optional|parameter|pointer|save|target +}imsx; +# Matches a name +my $RE_NAME = qr{[A-Za-z]\w*}imsx; +# Matches a specification type +my $RE_SPEC = qr{ + character|complex|double\s*precision|integer|logical|real|type +}imsx; +# Matches the identifier of a program unit that does not have arguments +my $RE_UNIT_BASE = qr{block\s*data|module|program}imsx; +# Matches the identifier of a program unit that has arguments +my $RE_UNIT_CALL = qr{function|subroutine}imsx; +# Matches the identifier of any program unit +my $RE_UNIT = qr{$RE_UNIT_BASE|$RE_UNIT_CALL}msx; +my %RE = ( + # A comment line + COMMENT => qr{\A\s*(?:!|\z)}msx, + # A trailing comment, capture the expression before the comment + COMMENT_END => qr{\A([^'"]*?)\s*!.*\z}msx, + # A contination marker, capture the expression before the marker + CONT => qr{\A(.*)&\s*\z}msx, + # A contination marker at the beginning of a line, capture the marker and + # the expression after the marker + CONT_LEAD => qr{\A(\s*&)(.*)\z}msx, + # Capture a variable identifier, removing any type component expression + NAME_COMP => qr{\b($RE_NAME)(?:\s*\%\s*$RE_NAME)*\b}msx, + # Matches the first identifier in a line + NAME_LEAD => qr{\A\s*$RE_NAME\s*}msx, + # Captures a name identifier after a comma, and the expression after + NAME_LIST => qr{\A(?:.*?)\s*,\s*($RE_NAME)\b(.*)\z}msx, + # Captures the next quote character + QUOTE => qr{\A[^'"]*(['"])}msx, + # Matches an attribute declaration + TYPE_ATTR => qr{\A\s*($RE_ATTR)\b}msx, + # Matches a type declaration + TYPE_SPEC => qr{\A\s*($RE_SPEC)\b}msx, + # Captures the expression after one or more program unit attributes + UNIT_ATTR => qr{\A\s*(?:(?:elemental|recursive|pure)\s+)+(.*)\z}imsx, + # Captures the identifier and the symbol of a program unit with no arguments + UNIT_BASE => qr{\A\s*($RE_UNIT_BASE)\s+($RE_NAME)\s*\z}imsx, + # Captures the identifier and the symbol of a program unit with arguments + UNIT_CALL => qr{\A\s*($RE_UNIT_CALL)\s+($RE_NAME)\b}imsx, + # Captures the end of a program unit, its identifier and its symbol + UNIT_END => qr{\A\s*(end)(?:\s+($RE_NAME)(?:\s+($RE_NAME))?)?\s*\z}imsx, + # Captures the expression after a program unit type specification + UNIT_SPEC => qr{\A\s*$RE_SPEC\b(.*)\z}imsx, +); + +# Keywords in type declaration statements +my %TYPE_DECL_KEYWORD_SET = map { ($_, 1) } qw{ + allocatable + dimension + in + inout + intent + kind + len + optional + out + parameter + pointer + save + target +}; + +# Creates and returns an instance of this class. +sub new { + my ($class) = @_; + bless( + sub { + my $key = shift(); + if (!exists($ACTION_OF{$key})) { + return; + } + $ACTION_OF{$key}->(@_); + }, + $class, + ); +} + +# Methods. +for my $key (keys(%ACTION_OF)) { + no strict qw{refs}; + *{$key} = sub { my $self = shift(); $self->($key, @_) }; +} + +# Extracts the calling interfaces of top level subroutines and functions from +# the $handle for reading Fortran sources. +sub _extract_interface { + my ($handle) = @_; + map { _present_line($_) } @{_reduce_to_interface(_load($handle))}; +} + +# Reads $handle for the next Fortran statement, handling continuations. +sub _load { + my ($handle) = @_; + my $ctx = {signature_token_set_of => {}, statements => []}; + my $state = { + in_contains => undef, # in a "contains" section of a program unit + in_interface => undef, # in an "interface" block + in_quote => undef, # in a multi-line quote + stack => [], # program unit stack + }; + my $NEW_STATEMENT = sub { + { name => q{}, # statement name, e.g. function, integer, ... + lines => [], # original lines in the statement + line_number => 0, # line number (start) in the original source + symbol => q{}, # name of a program unit (signature, end) + type => q{}, # e.g. signature, use, type, attr, end + value => q{}, # the actual value of the statement + }; + }; + my $statement; +LINE: + while (my $line = readline($handle)) { + if (!defined($statement)) { + $statement = $NEW_STATEMENT->(); + } + my $value = $line; + chomp($value); + # Pre-processor directives and continuation + if (!$statement->{line_number} && index($value, '#') == 0) { + $statement->{line_number} = $.; + $statement->{name} = 'cpp'; + } + if ($statement->{name} eq 'cpp') { + push(@{$statement->{lines}}, $line); + $statement->{value} .= $value; + if (rindex($value, '\\') != length($value) - 1) { + $statement = undef; + } + next LINE; + } + # Normal Fortran + if ($value =~ $RE{COMMENT}) { + next LINE; + } + if (!$statement->{line_number}) { + $statement->{line_number} = $.; + } + my ($cont_head, $cont_tail); + if ($statement->{line_number} != $.) { # is a continuation + ($cont_head, $cont_tail) = $value =~ $RE{CONT_LEAD}; + if ($cont_head) { + $value = $cont_tail; + } + } + # Correctly handle ! and & in quotes + my ($head, $tail) = (q{}, $value); + if ($state->{in_quote} && index($value, $state->{in_quote}) >= 0) { + my $index = index($value, $state->{in_quote}); + $head = substr($value, 0, $index + 1); + $tail + = length($value) > $index + 1 + ? substr($value, $index + 2) + : q{}; + $state->{in_quote} = undef; + } + if (!$state->{in_quote}) { + while ($tail) { + if (index($tail, q{!}) >= 0) { + if (!($tail =~ s/$RE{COMMENT_END}/$1/)) { + ($head, $tail, $state->{in_quote}) + = _load_extract_quote($head, $tail); + } + } + else { + while (index($tail, q{'}) > 0 + || index($tail, q{"}) > 0) + { + ($head, $tail, $state->{in_quote}) + = _load_extract_quote($head, $tail); + } + $head .= $tail; + $tail = q{}; + } + } + } + $cont_head ||= q{}; + push(@{$statement->{lines}}, $cont_head . $head . $tail . "\n"); + $statement->{value} .= $head . $tail; + # Process a statement only if it is marked with a continuation + if (!($statement->{value} =~ s/$RE{CONT}/$1/)) { + $statement->{value} =~ s{\s+\z}{}msx; + if (_process($statement, $ctx, $state)) { + push(@{$ctx->{statements}}, $statement); + } + $statement = undef; + } + } + return $ctx; +} + +# Helper, removes a quoted string from $tail. +sub _load_extract_quote { + my ($head, $tail) = @_; + my ($extracted, $remainder, $prefix) + = extract_delimited($tail, q{'"}, qr{[^'"]*}msx, q{}); + if ($extracted) { + return ($head . $prefix . $extracted, $remainder); + } + else { + my ($quote) = $tail =~ $RE{QUOTE}; + return ($head . $tail, q{}, $quote); + } +} + +# Study statements and put attributes into array $statements +sub _process { + my ($statement, $ctx, $state) = @_; + my $name; + + # End Interface + if ($state->{in_interface}) { + if ($statement->{value} =~ qr{\A\s*end\s*interface\b}imsx) { + $state->{in_interface} = 0; + } + return; + } + + # End Program Unit + if (@{$state->{stack}} && $statement->{value} =~ qr{\A\s*end\b}imsx) { + my ($end, $type, $symbol) = lc($statement->{value}) =~ $RE{UNIT_END}; + if (!$end) { + return; + } + my ($top_type, $top_symbol) = @{$state->{stack}->[-1]}; + if (!$type + || $top_type eq $type && (!$symbol || $top_symbol eq $symbol)) + { + pop(@{$state->{stack}}); + if ($state->{in_contains} && !@{$state->{stack}}) { + $state->{in_contains} = 0; + } + if (!$state->{in_contains}) { + $statement->{name} = $top_type; + $statement->{symbol} = $top_symbol; + $statement->{type} = 'end'; + return $statement; + } + } + return; + } + + # Interface/Contains + ($name) = $statement->{value} =~ qr{\A\s*(contains|interface)\b}imsx; + if ($name) { + $state->{'in_' . lc($name)} = 1; + return; + } + + # Program Unit + my ($type, $symbol, @tokens) = _process_prog_unit($statement->{value}); + if ($type) { + push(@{$state->{stack}}, [$type, $symbol]); + if ($state->{in_contains}) { + return; + } + $statement->{name} = lc($type); + $statement->{type} = 'signature'; + $statement->{symbol} = lc($symbol); + $ctx->{signature_token_set_of}{$symbol} + = {map { (lc($_) => 1) } @tokens}; + return $statement; + } + if ($state->{in_contains}) { + return; + } + + # Use + if ($statement->{value} =~ qr{\A\s*(use)\b}imsx) { + $statement->{name} = 'use'; + $statement->{type} = 'use'; + return $statement; + } + + # Type Declarations + ($name) = $statement->{value} =~ $RE{TYPE_SPEC}; + if ($name) { + $name =~ s{\s}{}gmsx; + $statement->{name} = lc($name); + $statement->{type} = 'type'; + return $statement; + } + + # Attribute Statements + ($name) = $statement->{value} =~ $RE{TYPE_ATTR}; + if ($name) { + $statement->{name} = $name; + $statement->{type} = 'attr'; + return $statement; + } +} + +# Parse a statement for program unit header. Returns a list containing the type, +# the symbol and the signature tokens of the program unit. +sub _process_prog_unit { + my ($string) = @_; + my ($type, $symbol, @args) = (q{}, q{}); + # Is it a blockdata, module or program? + ($type, $symbol) = $string =~ $RE{UNIT_BASE}; + if ($type) { + $type = lc($type); + $type =~ s{\s*}{}gmsx; + return ($type, $symbol); + } + # Remove the attribute and type declaration of a procedure + $string =~ s/$RE{UNIT_ATTR}/$1/; + my ($match) = $string =~ $RE{UNIT_SPEC}; + if ($match) { + $string = $match; + extract_bracketed($string); + } + # Is it a function or subroutine? + ($type, $symbol) = lc($string) =~ $RE{UNIT_CALL}; + if (!$type) { + return; + } + my $extracted = extract_bracketed($string, q{()}, qr{[^(]*}msx); + + # Get signature tokens from SUBROUTINE/FUNCTION + if ($extracted) { + $extracted =~ s{\s}{}gmsx; + @args = split(q{,}, substr($extracted, 1, length($extracted) - 2)); + if ($type eq 'function') { + my $result = extract_bracketed($string, q{()}, qr{[^(]*}msx); + if ($result) { + $result =~ s{\A\(\s*(.*?)\s*\)\z}{$1}msx; # remove braces + push(@args, $result); + } + else { + push(@args, $symbol); + } + } + } + return (lc($type), lc($symbol), map { lc($_) } @args); +} + +# Reduces the list of statements to contain only the interface block. +sub _reduce_to_interface { + my ($ctx) = @_; + my (%token_set, @interface_statements); +STATEMENT: + for my $statement (reverse(@{$ctx->{statements}})) { + if ($statement->{type} eq 'end' + && grep { $_ eq $statement->{name} } qw{subroutine function}) + { + push(@interface_statements, $statement); + %token_set + = %{$ctx->{signature_token_set_of}{$statement->{symbol}}}; + next STATEMENT; + } + if ($statement->{type} eq 'signature' + && grep { $_ eq $statement->{name} } qw{subroutine function}) + { + push(@interface_statements, $statement); + %token_set = (); + next STATEMENT; + } + if ($statement->{type} eq 'use') { + my ($head, $tail) + = split(qr{\s*:\s*}msx, lc($statement->{value}), 2); + if ($tail) { + my @imports = map { [split(qr{\s*=>\s*}msx, $_, 2)] } + split(qr{\s*,\s*}msx, $tail); + my @useful_imports + = grep { exists($token_set{$_->[0]}) } @imports; + if (!@useful_imports) { + next STATEMENT; + } + if (@imports != @useful_imports) { + my @token_strings + = map { $_->[0] . ($_->[1] ? ' => ' . $_->[1] : q{}) } + @useful_imports; + my ($last, @rest) = reverse(@token_strings); + my @token_lines + = (reverse(map { $_ . q{,&} } @rest), $last); + push( + @interface_statements, + { lines => [ + sprintf("%s:&\n", $head), + (map { sprintf(" & %s\n", $_) } @token_lines), + ] + }, + ); + next STATEMENT; + } + } + push(@interface_statements, $statement); + next STATEMENT; + } + if ($statement->{type} eq 'attr') { + my ($spec, @tokens) = ($statement->{value} =~ /$RE{NAME_COMP}/g); + if (grep { exists($token_set{$_}) } @tokens) { + for my $token (@tokens) { + $token_set{$token} = 1; + } + push(@interface_statements, $statement); + next STATEMENT; + } + } + if ($statement->{type} eq 'type') { + my ($variable_string, $spec_string) + = reverse(split('::', lc($statement->{value}), 2)); + if ($spec_string) { + $spec_string =~ s{$RE{NAME_LEAD}}{}msx; + } + else { + # The first expression in the statement is the type + attrib + $variable_string =~ s{$RE{NAME_LEAD}}{}msx; + $spec_string = extract_bracketed($variable_string, '()', + qr{[\s\*]*}msx); + } + # Useful tokens are those that comes after a comma + my $tail = q{,} . lc($variable_string); + my @tokens; + while ($tail) { + if ($tail =~ qr{\A\s*['"]}msx) { + extract_delimited($tail, q{'"}, qr{\A[^'"]*}msx, q{}); + } + elsif ($tail =~ qr{\A\s*\(}msx) { + extract_bracketed($tail, '()', qr{\A[^(]*}msx); + } + else { + my $token; + ($token, $tail) = $tail =~ $RE{NAME_LIST}; + if ($token && $token_set{$token}) { + @tokens = ($variable_string =~ /$RE{NAME_COMP}/g); + $tail = q{}; + } + } + } + if (@tokens && $spec_string) { + my @spec_tokens = (lc($spec_string) =~ /$RE{NAME_COMP}/g); + push( + @tokens, + ( grep { !exists($TYPE_DECL_KEYWORD_SET{$_}) } + @spec_tokens + ), + ); + } + if (grep { exists($token_set{$_}) } @tokens) { + for my $token (@tokens) { + $token_set{$token} = 1; + } + push(@interface_statements, $statement); + next STATEMENT; + } + } + } + if (!@interface_statements) { + return []; + } + [ {lines => ["interface\n"]}, + reverse(@interface_statements), + {lines => ["end interface\n"]}, + ]; +} + +# Processes and returns the line of the statement. +sub _present_line { + my ($statement) = @_; + map { + s{\s+}{ }gmsx; # collapse multiple spaces + s{\s+\z}{\n}msx; # remove trailing spaces + $_; + } @{$statement->{lines}}; +} + +# ------------------------------------------------------------------------------ +1; +__END__ + +=head1 NAME + +Fcm::Build::Fortran + +=head1 SYNOPSIS + + use Fcm::Build::Fortran; + my $fortran_util = Fcm::Build::Fortran->new(); + open(my($handle), '<', $path_to_a_fortran_source_file); + print($fortran_util->extract_interface($handle)); # prints interface + close($handle); + +=head1 DESCRIPTION + +A class to analyse Fortran source. Currently, it has a single method to extract +the calling interfaces of top level subroutines and functions in a Fortran +source. + +=head1 METHODS + +=over 4 + +=item $class->new() + +Creates and returns an instance of this class. + +=item $instance->extract_interface($handle) + +Extracts the calling interfaces of top level subroutines and functions in a +Fortran source that can be read from $handle. Returns an interface block as a +list of lines. + +=back + +=head1 ACKNOWLEDGEMENT + +This module is inspired by the logic developed by the European Centre +for Medium-Range Weather Forecasts (ECMWF). + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/06/06d874c692a6c37f4627fa143a43127e5f21a113.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/06/06d874c692a6c37f4627fa143a43127e5f21a113.svn-base new file mode 100644 index 0000000..c3a8e4c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/06/06d874c692a6c37f4627fa143a43127e5f21a113.svn-base @@ -0,0 +1,506 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ReposBranch +# +# DESCRIPTION +# This class contains methods for gathering information for a repository +# branch. It currently supports Subversion repository and local user +# directory. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use warnings; +use strict; + +package Fcm::ReposBranch; +use base qw{Fcm::Base}; + +use Fcm::CfgLine; +use Fcm::Keyword; +use Fcm::Util qw{expand_tilde is_url run_command w_report}; +use File::Basename qw{dirname}; +use File::Find qw{find}; +use File::Spec; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'package', # package name of which this repository belongs + 'repos', # repository branch root URL/path + 'revision', # the revision of this branch + 'tag', # "tag" name of this branch of the repository + 'type', # repository type +); + +# List of hash property methods for this class +my @hash_properties = ( + 'dirs', # list of non-recursive directories in this branch + 'expdirs', # list of recursive directories in this branch +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ReposBranch->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ReposBranch class. See +# @scalar_properties above for allowed list of properties in the constructor. +# (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + $self->{$_} = {} for (@hash_properties); + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_revision; +# +# DESCRIPTION +# This method expands the revision keywords of the current branch to a +# revision number. It returns true on success. +# ------------------------------------------------------------------------------ + +sub expand_revision { + my $self = shift; + + my $rc = 1; + if ($self->type eq 'svn') { + # Expand revision keyword + my $rev = (Fcm::Keyword::expand($self->repos(), $self->revision()))[1]; + + # Get last changed revision of the specified revision + my $info_ref = $self->_svn_info($self->repos(), $rev); + if (!defined($info_ref->{'Revision'})) { + my $url = $self->repos() . ($rev ? '@' . $rev : q{}); + w_report("ERROR: $url: not a valid URL\n"); + return 0; + } + my $lc_rev = $info_ref->{'Last Changed Rev'}; + $rev = $info_ref->{'Revision'}; + + # Print info if specified revision is not the last commit revision + if (uc($self->revision()) ne 'HEAD' && $lc_rev != $rev) { + my $message = $self->repos . '@' . $rev . ': last changed at [' . + $lc_rev . '].'; + if ($self->setting ('EXT_REVMATCH') and uc ($self->revision) ne 'HEAD') { + w_report "ERROR: specified and last changed revisions differ:\n", + ' ', $message, "\n"; + $rc = 0; + + } else { + print 'INFO: ', $message, "\n"; + } + } + + if ($self->verbose > 1 and uc ($self->revision) ne 'HEAD') { + # See if there is a later change of the branch at the HEAD + my $head_lc_rev = $self->_svn_info($self->repos())->{'Last Changed Rev'}; + + if (defined($head_lc_rev) && $head_lc_rev != $lc_rev) { + # Ensure that this is the same branch by checking its history + my @lines = &run_command ( + [qw/svn log -q --incremental -r/, $lc_rev, $self->repos . '@HEAD'], + METHOD => 'qx', TIME => $self->verbose > 2, + ); + + print 'INFO: ', $self->repos, '@', $rev, + ': newest commit at [', $head_lc_rev, '].', "\n" + if @lines; + } + } + + $self->revision ($rev) if $rev ne $self->revision; + + } elsif ($self->type eq 'user') { + 1; # Do nothing + + } else { + w_report 'ERROR: ', $self->repos, ': repository type "', $self->type, + '" not supported.'; + $rc = 0; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_path; +# +# DESCRIPTION +# This method expands the relative path names of sub-directories to full +# path names. It returns true on success. +# ------------------------------------------------------------------------------ + +sub expand_path { + my $self = shift; + + my $rc = 1; + if ($self->type eq 'svn') { + # SVN repository + # Do nothing unless there is a declared repository for this branch + return unless $self->repos; + + # Remove trailing / + my $repos = $self->repos; + $self->repos ($repos) if $repos =~ s#/+$##; + + # Consider all declared (expandable) sub-directories + for my $name (qw/dirs expdirs/) { + for my $dir (keys %{ $self->$name }) { + # Do nothing if declared sub-directory is quoted as a full URL + next if &is_url ($self->$name ($dir)); + + # Expand sub-directory to full URL + $self->$name ($dir, $self->repos . ( + $self->$name ($dir) ? ('/' . $self->$name ($dir)) : '' + )); + } + } + # Note: "catfile" cannot be used in the above statement because it has + # the tendency of removing a slash from double slashes. + + } elsif ($self->type eq 'user') { + # Local user directories + + # Expand leading ~ for all declared (expandable) sub-directories + for my $name (qw/dirs expdirs/) { + for my $dir (keys %{ $self->$name }) { + $self->$name ($dir, expand_tilde $self->$name ($dir)); + } + } + + # A top directory for the source is declared + if ($self->repos) { + # Expand leading ~ for the top directory + $self->repos (expand_tilde $self->repos); + + # Get the root directory of the file system + my $rootdir = File::Spec->rootdir (); + + # Expand top directory to absolute path, if necessary + $self->repos (File::Spec->rel2abs ($self->repos)) + if $self->repos !~ m/^$rootdir/; + + # Remove trailing / + my $repos = $self->repos; + $self->repos ($repos) if $repos =~ s#/+$##; + + # Consider all declared (expandable) sub-directories + for my $name (qw/dirs expdirs/) { + for my $dir (keys %{ $self->$name }) { + # Do nothing if declared sub-directory is quoted as a full path + next if $self->$name ($dir) =~ m#^$rootdir#; + + # Expand sub-directory to full path + $self->$name ( + $dir, $self->$name ($dir) + ? File::Spec->catfile ($self->repos, $self->$name ($dir)) + : $self->repos + ); + } + } + } + + } else { + w_report 'ERROR: ', $self->repos, ': repository type "', $self->type, + '" not supported.'; + $rc = 0; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_all(); +# +# DESCRIPTION +# This method searches the expandable source directories recursively for +# source directories containing regular files. The namespaces and the locators +# of these sub-directories are then added to the source directory hash table. +# Returns true on success. +# ------------------------------------------------------------------------------ + +sub expand_all { + my ($self) = @_; + my %finder_of = ( + user => sub { + my ($root_locator) = @_; + my %ns_of; + my $wanted = sub { + my $base_name = $_; + my $path = $File::Find::name; + if (-f $path && -r $path && !-l $path) { + my $dir_path = dirname($path); + my $rel_dir_path = File::Spec->abs2rel($dir_path, $root_locator); + if (!exists($ns_of{$dir_path})) { + $ns_of{$dir_path} = [File::Spec->splitdir($rel_dir_path)]; + } + } + }; + find($wanted, $root_locator); + return \%ns_of; + }, + svn => sub { + my ($root_locator) = @_; + my $runner = sub { + map {chomp($_); $_} run_command( + ['svn', @_, '-R', join('@', $root_locator, $self->revision())], + METHOD => 'qx', TIME => $self->config()->verbose() > 2, + ); + }; + # FIXME: check for symlink switched off due to "svn pg" being very slow + #my %symlink_in + # = map {($_ =~ qr{\A(.+)\s-\s(\*)\z}xms)} ($runner->(qw{pg svn:special})); + #my @locators + # = grep {$_ !~ qr{/\z}xms && !$symlink_in{$_}} ($runner->('ls')); + my @locators = grep {$_ !~ qr{/\z}xms} ($runner->('ls')); + my %ns_of; + for my $locator (@locators) { + my ($rel_dir_locator) = $locator =~ qr{\A(.*)/[^/]+\z}xms; # dirname + $rel_dir_locator ||= q{}; + my $dir_locator = join(q{/}, $root_locator, $rel_dir_locator); + if (!exists($ns_of{$dir_locator})) { + $ns_of{$dir_locator} = [split(q{/}, $rel_dir_locator)]; + } + } + return \%ns_of; + }, + ); + + if (!defined($finder_of{$self->type()})) { + w_report(sprintf( + qq{ERROR: %s: resource type "%s" not supported}, + $self->repos(), + $self->type(), + )); + return; + } + while (my ($root_ns, $root_locator) = each(%{$self->expdirs()})) { + my @root_ns_list = split(qr{$Fcm::Config::DELIMITER}xms, $root_ns); + my $ns_hash_ref = $finder_of{$self->type()}->($root_locator); + while (my ($dir_path, $ns_list_ref) = each(%{$ns_hash_ref})) { + if (!grep {$_ =~ qr{\A\.}xms || $_ =~ qr{~\z}xms} @{$ns_list_ref}) { + my $ns = join($Fcm::Config::DELIMITER, @root_ns_list, @{$ns_list_ref}); + $self->dirs($ns, $dir_path); + } + } + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $n = $obj->add_base_dirs ($base); +# +# DESCRIPTION +# Add a list of source directories to the current branch based on the set +# provided by $base, which must be a reference to a Fcm::ReposBranch +# instance. It returns the total number of used sub-directories in the +# current repositories. +# ------------------------------------------------------------------------------ + +sub add_base_dirs { + my $self = shift; + my $base = shift; + + my %base_dirs = %{ $base->dirs }; + + for my $key (keys %base_dirs) { + # Remove repository root from base directories + if ($base_dirs{$key} eq $base->repos) { + $base_dirs{$key} = ''; + + } else { + $base_dirs{$key} = substr $base_dirs{$key}, length ($base->repos) + 1; + } + + # Append base directories to current repository root + $self->dirs ($key, $base_dirs{$key}); + } + + # Expand relative path names of sub-directories + $self->expand_path; + + return scalar keys %{ $self->dirs }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines (); +# +# DESCRIPTION +# This method returns a list of configuration lines for the current branch. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self) = @_; + my @return = (); + + my $suffix = $self->package . $Fcm::Config::DELIMITER . $self->tag; + push @return, Fcm::CfgLine->new ( + label => $self->cfglabel ('REPOS') . $Fcm::Config::DELIMITER . $suffix, + value => $self->repos, + ) if $self->repos; + + push @return, Fcm::CfgLine->new ( + label => $self->cfglabel ('REVISION') . $Fcm::Config::DELIMITER . $suffix, + value => $self->revision, + ) if $self->revision; + + for my $key (sort keys %{ $self->dirs }) { + my $value = $self->dirs ($key); + + # Use relative path where possible + if ($self->repos) { + if ($value eq $self->repos) { + $value = ''; + + } elsif (index ($value, $self->repos) == 0) { + $value = substr ($value, length ($self->repos) + 1); + } + } + + # Use top package name where possible + my $dsuffix = $key . $Fcm::Config::DELIMITER . $self->tag; + $dsuffix = $suffix if $value ne $self->dirs ($key) and $key eq join ( + $Fcm::Config::DELIMITER, $self->package, File::Spec->splitdir ($value) + ); + + push @return, Fcm::CfgLine->new ( + label => $self->cfglabel ('DIRS') . $Fcm::Config::DELIMITER . $dsuffix, + value => $value, + ); + } + + push @return, Fcm::CfgLine->new (); + + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# my $hash_ref = $self->_svn_info($url[, $rev]); +# +# DESCRIPTION +# Executes "svn info" and returns each field in a hash. +# ------------------------------------------------------------------------------ +sub _svn_info { + my ($self, $url, $rev) = @_; + return { + map { + chomp(); + my ($key, $value) = split(qr{\s*:\s*}xms, $_, 2); + $key ? ($key, $value) : (); + } run_command( + [qw{svn info}, ($rev ? ('-r', $rev, join('@', $url, $rev)) : $url)], + DEVNULL => 1, METHOD => 'qx', TIME => $self->verbose() > 2, + ) + }; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/07/072365a1874c7a832c6ef83a6c5bfa5d9fdf0d1d.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/07/072365a1874c7a832c6ef83a6c5bfa5d9fdf0d1d.svn-base new file mode 100644 index 0000000..7fa712a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/07/072365a1874c7a832c6ef83a6c5bfa5d9fdf0d1d.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::Browser'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/08/0864c04c7044d119686ead4cfc5b7730b1f888c6.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/08/0864c04c7044d119686ead4cfc5b7730b1f888c6.svn-base new file mode 100644 index 0000000..a8908d9 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/08/0864c04c7044d119686ead4cfc5b7730b1f888c6.svn-base @@ -0,0 +1,1217 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CmBranch +# +# DESCRIPTION +# This class contains methods for manipulating a branch. It is a sub-class of +# Fcm::CmUrl, and inherits all methods from that class. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CmBranch; +@ISA = qw(Fcm::CmUrl); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use Carp; +use File::Spec; + +# FCM component modules +use Fcm::CmCommitMessage; +use Fcm::CmUrl; +use Fcm::Config; +use Fcm::Interactive; +use Fcm::Keyword; +use Fcm::Util qw/run_command e_report w_report svn_date/; + +my @properties = ( + 'CREATE_REV', # revision at which the branch is created + 'DELETE_REV', # revision at which the branch is deleted + 'PARENT', # reference to parent branch Fcm::CmBranch + 'ANCESTOR', # list of common ancestors with other branches + # key = URL, value = ancestor Fcm::CmBranch + 'LAST_MERGE', # list of last merges from branches + # key = URL@REV, value = [TARGET, UPPER, LOWER] + 'AVAIL_MERGE', # list of available revisions for merging + # key = URL@REV, value = [REV ...] + 'CHILDREN', # list of children of this branch + 'SIBLINGS', # list of siblings of this branch +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch = Fcm::CmBranch->new (URL => $url,); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CmBranch class. +# +# ARGUMENTS +# URL - URL of a branch +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::CmUrl->new (%args); + + $self->{$_} = undef for (@properties); + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_branch->url_peg; +# $cm_branch->url_peg ($url); +# +# DESCRIPTION +# This method returns/sets the current URL. +# ------------------------------------------------------------------------------ + +sub url_peg { + my $self = shift; + + if (@_) { + if (! $self->{URL} or $_[0] ne $self->{URL}) { + # Re-set URL and other essential variables in the SUPER-class + $self->SUPER::url_peg (@_); + + # Re-set essential variables + $self->{$_} = undef for (@properties); + } + } + + return $self->{URL}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $cm_branch->create_rev; +# +# DESCRIPTION +# This method returns the revision at which the branch was created. +# ------------------------------------------------------------------------------ + +sub create_rev { + my $self = shift; + + if (not $self->{CREATE_REV}) { + return unless $self->url_exists ($self->pegrev); + + # Use "svn log" to find out the first revision of the branch + my %log = $self->svnlog (STOP_ON_COPY => 1); + + # Look at log in ascending order + my $rev = (sort {$a <=> $b} keys %log) [0]; + my $paths = $log{$rev}{paths}; + + # Get revision when URL is first added to the repository + if (exists $paths->{$self->branch_path}) { + $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A'; + } + } + + return $self->{CREATE_REV}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $parent = $cm_branch->parent; +# +# DESCRIPTION +# This method returns the parent (a Fcm::CmBranch object) of the current +# branch. +# ------------------------------------------------------------------------------ + +sub parent { + my $self = shift; + + if (not $self->{PARENT}) { + # Use the log to find out the parent revision + my %log = $self->svnlog (REV => $self->create_rev); + + if (exists $log{paths}{$self->branch_path}) { + my $path = $log{paths}{$self->branch_path}; + + if ($path->{action} eq 'A') { + if (exists $path->{'copyfrom-path'}) { + # Current branch is copied from somewhere, set the source as the parent + my $url = $self->root . $path->{'copyfrom-path'}; + my $rev = $path->{'copyfrom-rev'}; + $self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev); + + } else { + # Current branch is not copied from somewhere + $self->{PARENT} = $self; + } + } + } + } + + return $self->{PARENT}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $cm_branch->delete_rev; +# +# DESCRIPTION +# This method returns the revision at which the branch was deleted. +# ------------------------------------------------------------------------------ + +sub delete_rev { + my $self = shift; + + if (not $self->{DELETE_REV}) { + return if $self->url_exists ('HEAD'); + + # Container of the current URL + (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##; + + # Use "svn log" on the container between a revision where the branch exists + # and the HEAD + my $dir = Fcm::CmUrl->new (URL => $dir_url); + my %log = $dir->svnlog ( + REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)], + ); + + # Go through the log to see when branch no longer exists + for my $rev (sort {$a <=> $b} keys %log) { + next unless exists $log{$rev}{paths}{$self->branch_path} and + $log{$rev}{paths}{$self->branch_path}{action} eq 'D'; + + $self->{DELETE_REV} = $rev; + last; + } + } + + return $self->{DELETE_REV}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_branch->is_child_of ($branch); +# +# DESCRIPTION +# This method returns true if the current branch is a child of $branch. +# ------------------------------------------------------------------------------ + +sub is_child_of { + my ($self, $branch) = @_; + + # The trunk cannot be a child branch + return if $self->is_trunk; + + # If $branch is a branch, use name of $self to see when it is created + if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) { + my $rev = $1; + + # $self can only be a child if it is copied from a revision > the create + # revision of $branch + return if $rev < $branch->create_rev; + } + + return if $self->parent->url ne $branch->url; + + # If $branch is a branch, ensure that it is created before $self + return if $branch->is_branch and $self->create_rev <= $branch->create_rev; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_branch->is_sibling_of ($branch); +# +# DESCRIPTION +# This method returns true if the current branch is a sibling of $branch. +# ------------------------------------------------------------------------------ + +sub is_sibling_of { + my ($self, $branch) = @_; + + # The trunk cannot be a sibling branch + return if $branch->is_trunk; + + return if $self->parent->url ne $branch->parent->url; + + # If the parent is a branch, ensure they are actually the same branch + return if $branch->parent->is_branch and + $self->parent->create_rev != $branch->parent->create_rev; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $self->_get_relatives ($relation); +# +# DESCRIPTION +# This method sets the $self->{$relation} variable by inspecting the list of +# branches at the current revision of the current branch. $relation can be +# either "CHILDREN" or "SIBLINGS". +# ------------------------------------------------------------------------------ + +sub _get_relatives { + my ($self, $relation) = @_; + + my @branch_list = $self->branch_list; + + $self->{$relation} = []; + + # If we are searching for CHILDREN, get list of SIBLINGS, and vice versa + my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN'); + my %other_list; + if ($self->{$other}) { + %other_list = map {$_->url, 1} @{ $self->{$other} }; + } + + for my $u (@branch_list) { + # Ignore URL of current branch and its parent + next if $u eq $self->url; + next if $self->is_branch and $u eq $self->parent->url; + + # Ignore if URL is a branch detected to be another type of relative + next if exists $other_list{$u}; + + # Construct new Fcm::CmBranch object from branch URL + my $url = $u . ($self->pegrev ? '@' . $self->pegrev : ''); + my $branch = Fcm::CmBranch->new (URL => $url); + + # Test whether $branch is a relative we are looking for + if ($relation eq 'CHILDREN') { + push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self); + + } else { + push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self); + } + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @children = $cm_branch->children; +# +# DESCRIPTION +# This method returns a list of children (Fcm::CmBranch objects) of the +# current branch that exists in the current revision. +# ------------------------------------------------------------------------------ + +sub children { + my $self = shift; + + $self->_get_relatives ('CHILDREN') if not $self->{CHILDREN}; + + return @{ $self->{CHILDREN} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @siblings = $cm_branch->siblings; +# +# DESCRIPTION +# This method returns a list of siblings (Fcm::CmBranch objects) of the +# current branch that exists in the current revision. +# ------------------------------------------------------------------------------ + +sub siblings { + my $self = shift; + + $self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS}; + + return @{ $self->{SIBLINGS} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $ancestor = $cm_branch->ancestor ($branch); +# +# DESCRIPTION +# This method returns the common ancestor (a Fcm::CmBranch object) of a +# specified $branch and the current branch. The argument $branch must be a +# Fcm::CmBranch object. Both the current branch and $branch are assumed to be +# in the same project. +# ------------------------------------------------------------------------------ + +sub ancestor { + my ($self, $branch) = @_; + + if (not exists $self->{ANCESTOR}{$branch->url_peg}) { + if ($self->url_peg eq $branch->url_peg) { + $self->{ANCESTOR}{$branch->url_peg} = $self; + + } else { + # Get family tree of current branch, from trunk to current branch + my @this_family = ($self); + while (not $this_family [0]->is_trunk) { + unshift @this_family, $this_family [0]->parent; + } + + # Get family tree of $branch, from trunk to $branch + my @that_family = ($branch); + while (not $that_family [0]->is_trunk) { + unshift @that_family, $that_family [0]->parent; + } + + # Find common ancestor from list of parents + my $ancestor = undef; + + while (not $ancestor) { + # $this and $that should both start as some revisions on the trunk. + # Walk down a generation each time it loops around. + my $this = shift @this_family; + my $that = shift @that_family; + + if ($this->url eq $that->url) { + if ($this->is_trunk or $this->create_rev eq $that->create_rev) { + # $this and $that are the same branch + if (@this_family and @that_family) { + # More generations in both branches, try comparing the next + # generations. + next; + + } else { + # End of lineage in one of the branches, ancestor is at the lower + # revision of the current URL. + if ($this->pegrev and $that->pegrev) { + $ancestor = $this->pegrev < $that->pegrev ? $this : $that; + + } else { + $ancestor = $this->pegrev ? $this : $that; + } + } + + } else { + # Despite the same URL, $this and $that are different branches as + # they are created at different revisions. The ancestor must be the + # parent with the lower revision. (This should not occur at the + # start.) + $ancestor = $this->parent->pegrev < $that->parent->pegrev + ? $this->parent : $that->parent; + } + + } else { + # Different URLs, ancestor must be the parent with the lower revision. + # (This should not occur at the start.) + $ancestor = $this->parent->pegrev < $that->parent->pegrev + ? $this->parent : $that->parent; + } + } + + $self->{ANCESTOR}{$branch->url_peg} = $ancestor; + } + } + + return $self->{ANCESTOR}{$branch->url_peg}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($target, $upper, $lower) = $cm_branch->last_merge_from ( +# $branch, $stop_on_copy, +# ); +# +# DESCRIPTION +# This method returns a 3-element list with information of the last merge +# into the current branch from a specified $branch. The first element in the +# list $target (a Fcm::CmBranch object) is the target at which the merge was +# performed. (This can be the current branch or a parent branch up to the +# common ancestor with the specified $branch.) The second and third elements, +# $upper and $lower, (both Fcm::CmBranch objects), are the upper and lower +# ends of the source delta. If there is no merge from $branch into the +# current branch from their common ancestor to the current revision, this +# method will return an empty list. If $stop_on_copy is specified, it ignores +# merges from parents of $branch, and merges into parents of the current +# branch. +# ------------------------------------------------------------------------------ + +sub last_merge_from { + my ($self, $branch, $stop_on_copy) = @_; + + if (not exists $self->{LAST_MERGE}{$branch->url_peg}) { + # Get "log" of current branch down to the common ancestor + my %log = $self->svnlog ( + REV => [ + ($self->pegrev ? $self->pegrev : 'HEAD'), + $self->ancestor ($branch)->pegrev, + ], + + STOP_ON_COPY => $stop_on_copy, + ); + + my $cr = $self; + + # Go down the revision log, checking for merge template messages + REV: for my $rev (sort {$b <=> $a} keys %log) { + # Loop each line of the log message at each revision + my @msg = split /\n/, $log{$rev}{msg}; + + # Also consider merges into parents of current branch + $cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev); + + for (@msg) { + # Ignore unless log message matches a merge template + next unless /Merged into \S+: (\S+) cf\. (\S+)/; + + # Upper $1 and lower $2 ends of the source delta + my $u_path = $1; + my $l_path = $2; + + # Add the root directory to the paths if necessary + $u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/'; + $l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/'; + + # Only consider merges with specified branch (and its parent) + (my $path = $u_path) =~ s/@(\d+)$//; + my $u_rev = $1; + + my $br = $branch; + $br = $br->parent while ( + $br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy + ); + + next unless $br->branch_path eq $path; + + # If $br is a parent of branch, ignore those merges with the parent + # above the branch point of the current branch + next if $br->pegrev and $br->pegrev < $u_rev; + + # Set the return values + $self->{LAST_MERGE}{$branch->url_peg} = [ + Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target + Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper + Fcm::CmBranch->new (URL => $self->root . $l_path), # delta lower + ]; + + last REV; + } + } + } + + return (exists $self->{LAST_MERGE}{$branch->url_peg} + ? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ()); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]); +# +# DESCRIPTION +# This method returns a list of revisions of a specified $branch, which are +# available for merging into the current branch. If $stop_on_copy is +# specified, it will not list available merges from the parents of $branch. +# ------------------------------------------------------------------------------ + +sub avail_merge_from { + my ($self, $branch, $stop_on_copy) = @_; + + if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) { + # Find out the revision of the upper delta at the last merge from $branch + # If no merge is found, use revision of common ancestor with $branch + my @last_merge = $self->last_merge_from ($branch); + my $rev = $self->ancestor ($branch)->pegrev; + $rev = $last_merge [1]->pegrev + if @last_merge and $last_merge [1]->pegrev > $rev; + + # Get the "log" of the $branch down to $rev + my %log = $branch->svnlog ( + REV => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev], + STOP_ON_COPY => $stop_on_copy, + ); + + # No need to include $rev itself, as it has already been merged + delete $log{$rev}; + + # No need to include the branch create revision + delete $log{$branch->create_rev} + if $branch->is_branch and exists $log{$branch->create_rev}; + + if (keys %log) { + # Check whether there is a latest merge from $self into $branch, if so, + # all revisions of $branch below that merge should become unavailable + my @last_merge_into = $branch->last_merge_from ($self); + + if (@last_merge_into) { + for my $rev (keys %log) { + delete $log{$rev} if $rev < $last_merge_into [0]->pegrev; + } + } + } + + # Available merges include all revisions above the branch creation revision + # or the revision of the last merge + $self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log]; + } + + return @{ $self->{AVAIL_MERGE}{$branch->url_peg} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $lower = $cm_branch->base_of_merge_from ($branch); +# +# DESCRIPTION +# This method returns the lower delta (a Fcm::CmBranch object) for the next +# merge from $branch. +# ------------------------------------------------------------------------------ + +sub base_of_merge_from { + my ($self, $branch) = @_; + + # Base is the ancestor if there is no merge between $self and $branch + my $return = $self->ancestor ($branch); + + # Get configuration for the last merge from $branch to $self + my @merge_from = $self->last_merge_from ($branch); + + # Use the upper delta of the last merge from $branch, as all revisions below + # that have already been merged into the $self + $return = $merge_from [1] + if @merge_from and $merge_from [1]->pegrev > $return->pegrev; + + # Get configuration for the last merge from $self to $branch + my @merge_into = $branch->last_merge_from ($self); + + # Use the upper delta of the last merge from $self, as the current revision + # of $branch already contains changes of $self up to the peg revision of the + # upper delta + $return = $merge_into [1] + if @merge_into and $merge_into [0]->pegrev > $return->pegrev; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir); +# +# DESCRIPTION +# This method returns true if a merge from the sub-directory $subdir in +# $branch is allowed - i.e. it does not result in losing changes made in +# $branch outside of $subdir. +# ------------------------------------------------------------------------------ + +sub allow_subdir_merge_from { + my ($self, $branch, $subdir) = @_; + + # Get revision at last merge from $branch or ancestor + my @merge_from = $self->last_merge_from ($branch); + my $last = @merge_from ? $merge_from [1] : $self->ancestor ($branch); + my $rev = $last->pegrev; + + my $return = 1; + if ($branch->pegrev > $rev) { + # Use "svn diff --summarize" to work out what's changed between last + # merge/ancestor and current revision + my $range = $branch->pegrev . ':' . $rev; + my @out = &run_command ( + [qw/svn diff --summarize -r/, $range, $branch->url_peg], METHOD => 'qx', + ); + + # Returns false if there are changes outside of $subdir + my $url = join ('/', $branch->url, $subdir); + for my $line (@out) { + chomp $line; + $line = substr ($line, 7); # file name begins at column 7 + if ($line !~ m#^$url(?:/|$)#) { + $return = 0; + last; + } + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch->create ( +# SRC => $src, +# TYPE => $type, +# NAME => $name, +# [PASSWORD => $password,] +# [REV_FLAG => $rev_flag,] +# [TICKET => \@tickets,] +# [REV => $rev,] +# [NON_INTERACTIVE => 1,] +# [SVN_NON_INTERACTIVE => 1,] +# ); +# +# DESCRIPTION +# This method creates a branch in a Subversion repository. +# +# OPTIONS +# SRC - reference to a Fcm::CmUrl object. +# TYPE - Specify the branch type. See help in "fcm branch" for +# further information. +# NAME - specify the name of the branch. +# NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE +# to true automatically. +# PASSWORD - specify the password for commit access. +# REV - specify the operative revision of the source. +# REV_FLAG - A flag to specify the behaviour of the prefix to the +# branch name. See help in "fcm branch" for further +# information. +# SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit, +# etc. This option is implied by NON_INTERACTIVE. +# TICKET - Specify one or more related tickets for the branch. +# ------------------------------------------------------------------------------ + +sub create { + my $self = shift; + my %args = @_; + + # Options + # ---------------------------------------------------------------------------- + # Compulsory options + my $src = $args{SRC}; + my $type = $args{TYPE}; + my $name = $args{NAME}; + + # Other options + my $rev_flag = $args{REV_FLAG} ? $args{REV_FLAG} : 'NORMAL'; + my @tickets = exists $args{TICKET} ? @{ $args{TICKET} } : (); + my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef; + my $orev = exists $args{REV} ? $args{REV} : 'HEAD'; + + my $non_interactive = exists $args{NON_INTERACTIVE} + ? $args{NON_INTERACTIVE} : 0; + my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE} + ? $args{SVN_NON_INTERACTIVE} : 0; + $svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive; + + # Analyse the source URL + # ---------------------------------------------------------------------------- + # Create branch from the trunk by default + $src->branch ('trunk') if not $src->branch; + + # Remove "sub-directory" part from source URL + $src->subdir ('') if $src->subdir; + + # Remove "peg revision" part because it does not work with "svn copy" + $src->pegrev ('') if $src->pegrev; + + # Find out the URL and the last changed revision of the specified URL at the + # specified operative revision + my $url = $src->svninfo (FLAG => 'URL', REV => $orev); + e_report $src->url, ': cannot determine the operative URL at revision ', + $orev, ', abort.' if not $url; + + $src->url ($url) if $url ne $src->url; + + my $rev = $src->svninfo (FLAG => 'Last Changed Rev', REV => $orev); + e_report $src->url, ': cannot determine the last changed rev at revision', + $orev, ', abort.' if not $rev; + + # Warn user if last changed revision is not the specified revision + w_report 'Warning: branch will be created from revision ', $rev, + ', i.e. the last changed rev.' + unless $orev and $orev eq $rev; + + # Determine the sub-directory names of the branch + # ---------------------------------------------------------------------------- + my @branch_dirs = ('branches'); + + # Split branch type flags into a hash table + my %type_flags = (); + $type_flags{$_} = 1 for ((split /$Fcm::Config::DELIMITER/, $type)); + + # Branch sub-directory 1, development, test or package + for my $flag (qw/DEV TEST PKG/) { + if (exists $type_flags{$flag}) { + push @branch_dirs, lc ($flag); + last; + } + } + + # Branch sub-directory 2, user, share, configuration or release + if (exists $type_flags{USER}) { + die 'Unable to determine your user ID, abort' unless $self->config->user_id; + + push @branch_dirs, $self->config->user_id; + + } else { + for my $flag (keys %Fcm::CmUrl::owner_keywords) { + if (exists $type_flags{uc ($flag)}) { + push @branch_dirs, $flag; + last; + } + } + } + + # Branch sub-directory 3, branch name + # Prefix branch name with revision number/keyword if necessary + my $prefix = ''; + if ($rev_flag ne 'NONE') { + $prefix = $rev; + + # Attempt to replace revision number with a revision keyword if necessary + if ($rev_flag eq 'NORMAL') { + $prefix = (Fcm::Keyword::unexpand($src->url_peg(), $rev))[1]; + } + + # $prefix is still a revision number, add "r" in front of it + $prefix = 'r' . $prefix if $prefix eq $rev; + + # Add an underscore before the branch name + $prefix.= '_'; + } + + # Branch name + push @branch_dirs, $prefix . $name; + + # Check whether the branch already exists, fail if so + # ---------------------------------------------------------------------------- + # Construct the URL of the branch + $self->project_url ($src->project_url); + $self->branch (join ('/', @branch_dirs)); + + # Check that branch does not already exists + e_report $self->url, ': branch already exists, abort.' if $self->url_exists; + + # Message for the commit log + # ---------------------------------------------------------------------------- + my @message = ('Created ' . $self->branch_path . ' from ' . + $src->branch_path . '@' . $rev . '.' . "\n"); + + # Add related Trac ticket links to commit log if set + if (@tickets) { + my $ticket_mesg = 'Relates to ticket' . (@tickets > 1 ? 's' : ''); + + while (my $ticket = shift @tickets) { + $ticket_mesg .= ' #' . $ticket; + $ticket_mesg .= (@tickets > 1 ? ',' : ' and') if @tickets >= 1; + } + + push @message, $ticket_mesg . ".\n"; + } + + # Create a temporary file for the commit log message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->auto_mesg (\@message); + $ci_mesg->ignore_mesg (['A' . ' ' x 4 . $self->url . "\n"]); + my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive); + + # Check with the user to see if he/she wants to go ahead + # ---------------------------------------------------------------------------- + if (not $non_interactive) { + my $reply = Fcm::Interactive::get_input( + title => 'fcm branch', + message => 'Would you like to go ahead and create this branch?', + type => 'yn', + default => 'n', + ); + + return unless $reply eq 'y'; + } + + # Ensure existence of container sub-directories of the branch + # ---------------------------------------------------------------------------- + for my $i (0 .. $#branch_dirs - 1) { + my $subdir = join ('/', @branch_dirs[0 .. $i]); + my $subdir_url = Fcm::CmUrl->new (URL => $src->project_url . '/' . $subdir); + + # Check whether each sub-directory of the branch already exists, + # if sub-directory does not exist, create it + next if $subdir_url->url_exists; + + print 'Creating sub-directory: ', $subdir, "\n"; + + my @command = ( + qw/svn mkdir/, + '-m', 'Created ' . $subdir . ' directory.', + ($svn_non_interactive ? '--non-interactive' : ()), + (defined $password ? ('--password', $password) : ()), + + $subdir_url->url, + ); + &run_command (\@command); + } + + # Create the branch + # ---------------------------------------------------------------------------- + { + print 'Creating branch ', $self->url, ' ...', "\n"; + my @command = ( + qw/svn copy/, + '-r', $rev, + '-F', $logfile, + ($svn_non_interactive ? '--non-interactive' : ()), + (defined $password ? ('--password', $password) : ()), + + $src->url, $self->url, + ); + &run_command (\@command); + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch->delete ( +# [NON_INTERACTIVE => 1,] +# [PASSWORD => $password,] +# [SVN_NON_INTERACTIVE => 1,] +# ); +# +# DESCRIPTION +# This method deletes the current branch from the Subversion repository. +# +# OPTIONS +# NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE +# to true automatically. +# PASSWORD - specify the password for commit access. +# SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit, +# etc. This option is implied by NON_INTERACTIVE. +# ------------------------------------------------------------------------------ + +sub del { + my $self = shift; + my %args = @_; + + # Options + # ---------------------------------------------------------------------------- + my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef; + my $non_interactive = exists $args{NON_INTERACTIVE} + ? $args{NON_INTERACTIVE} : 0; + my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE} + ? $args{SVN_NON_INTERACTIVE} : 0; + $svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive; + + # Ensure URL is a branch + # ---------------------------------------------------------------------------- + e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch; + + # Message for the commit log + # ---------------------------------------------------------------------------- + my @message = ('Deleted ' . $self->branch_path . '.' . "\n"); + + # Create a temporary file for the commit log message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->auto_mesg (\@message); + $ci_mesg->ignore_mesg (['D' . ' ' x 4 . $self->url . "\n"]); + my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive); + + # Check with the user to see if he/she wants to go ahead + # ---------------------------------------------------------------------------- + if (not $non_interactive) { + my $mesg = ''; + my $user = $self->config->user_id; + + if ($user and $self->branch_owner ne $user) { + $mesg .= "\n"; + + if (exists $Fcm::CmUrl::owner_keywords{$self->branch_owner}) { + my $type = $Fcm::CmUrl::owner_keywords{$self->branch_owner}; + $mesg .= '*** WARNING: YOU ARE DELETING A ' . uc ($type) . + ' BRANCH.'; + + } else { + $mesg .= '*** WARNING: YOU ARE DELETING A BRANCH NOT OWNED BY YOU.'; + } + + $mesg .= "\n" . + '*** Please ensure that you have the owner\'s permission.' . + "\n\n"; + } + + $mesg .= 'Would you like to go ahead and delete this branch?'; + + my $reply = Fcm::Interactive::get_input ( + title => 'fcm branch', + message => $mesg, + type => 'yn', + default => 'n', + ); + + return unless $reply eq 'y'; + } + + # Delete branch if answer is "y" for "yes" + # ---------------------------------------------------------------------------- + print 'Deleting branch ', $self->url, ' ...', "\n"; + my @command = ( + qw/svn delete/, + '-F', $logfile, + (defined $password ? ('--password', $password) : ()), + ($svn_non_interactive ? '--non-interactive' : ()), + + $self->url, + ); + &run_command (\@command); + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch->display_info ( +# [SHOW_CHILDREN => 1], +# [SHOW_OTHER => 1] +# [SHOW_SIBLINGS => 1] +# ); +# +# DESCRIPTION +# This method displays information of the current branch. If SHOW_CHILDREN is +# set, it shows information of all current children branches of the current +# branch. If SHOW_SIBLINGS is set, it shows information of siblings that have +# been merged recently with the current branch. If SHOW_OTHER is set, it shows +# information of custom/reverse merges. +# ------------------------------------------------------------------------------ + +sub display_info { + my $self = shift; + my %args = @_; + + # Arguments + # ---------------------------------------------------------------------------- + my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0; + my $show_other = exists $args{SHOW_OTHER } ? $args{SHOW_OTHER} : 0; + my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0; + + # Useful variables + # ---------------------------------------------------------------------------- + my $separator = '-' x 80 . "\n"; + my $separator2 = ' ' . '-' x 78 . "\n"; + + # Print "info" as returned by "svn info" + # ---------------------------------------------------------------------------- + for my $key ('URL', 'Repository Root', 'Revision', 'Last Changed Author', + 'Last Changed Rev', 'Last Changed Date') { + print $key, ': ', $self->svninfo (FLAG => $key), "\n" + if $self->svninfo (FLAG => $key); + } + + if ($self->config->verbose) { + # Verbose mode, print log message at last changed revision + my %log = $self->svnlog (REV => $self->svninfo (FLAG => 'Last Changed Rev')); + my @log = split /\n/, $log{msg}; + print 'Last Changed Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n"; + } + + if ($self->is_branch) { + # Print create information + # -------------------------------------------------------------------------- + my %log = $self->svnlog (REV => $self->create_rev); + + print $separator; + print 'Branch Create Author: ', $log{author}, "\n" if $log{author}; + print 'Branch Create Rev: ', $self->create_rev, "\n"; + print 'Branch Create Date: ', &svn_date ($log{date}), "\n"; + + if ($self->config->verbose) { + # Verbose mode, print log message at last create revision + my @log = split /\n/, $log{msg}; + print 'Branch Create Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n"; + } + + # Print delete information if branch no longer exists + # -------------------------------------------------------------------------- + print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev; + + # Report merges into/from the parent + # -------------------------------------------------------------------------- + # Print the URL@REV of the parent branch + print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n"; + + # Set up a new object for the parent at the current revision + # -------------------------------------------------------------------------- + my $p_url = $self->parent->url; + $p_url .= '@' . $self->pegrev if $self->pegrev; + my $parent = Fcm::CmBranch->new (URL => $p_url); + + if (not $parent->url_exists) { + print 'Branch parent deleted.', "\n"; + return; + } + + # Report merges into/from the parent + # -------------------------------------------------------------------------- + print $self->_report_merges ($parent, 'Parent'); + } + + # Report merges with siblings + # ---------------------------------------------------------------------------- + if ($show_siblings) { + # Report number of sibling branches found + print $separator, 'Searching for siblings ... '; + my @siblings = $self->siblings; + print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'), + ' found.', "\n"; + + # Report branch name and merge information only if there are recent merges + my $out = ''; + for my $sibling (@siblings) { + my $string = $self->_report_merges ($sibling, 'Sibling'); + + $out .= $separator2 . ' ' . $sibling->url . "\n" . $string if $string; + } + + if (@siblings) { + if ($out) { + print 'Merges with existing siblings:', "\n", $out; + + } else { + print 'No merges with existing siblings.', "\n"; + } + } + } + + # Report children + # ---------------------------------------------------------------------------- + if ($show_children) { + # Report number of child branches found + print $separator, 'Searching for children ... '; + my @children = $self->children; + print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'), + ' found.', "\n"; + + # Report children if they exist + print 'Current children:', "\n" if @children; + + for my $child (@children) { + print $separator2, ' ', $child->url, "\n"; + print ' Child Create Rev: ', $child->create_rev, "\n"; + print $self->_report_merges ($child, 'Child'); + } + } + + # Report custom/reverse merges into the branch + # ---------------------------------------------------------------------------- + if ($show_other) { + my %log = $self->svnlog (STOP_ON_COPY => 1); + my @out; + + # Go down the revision log, checking for merge template messages + REV: for my $rev (sort {$b <=> $a} keys %log) { + # Loop each line of the log message at each revision + my @msg = split /\n/, $log{$rev}{msg}; + + for (@msg) { + # Ignore unless log message matches a merge template + if (/^Reversed r\d+(:\d+)? of \S+$/ or + s/^(Custom merge) into \S+(:.+)$/$1$2/) { + push @out, ('r' . $rev . ': ' . $_) . "\n"; + } + } + } + + print $separator, 'Other merges:', "\n", @out if @out; + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_report_merges ($branch, $relation); +# +# DESCRIPTION +# This method returns a string for displaying merge information with a +# branch, the $relation of which can be a Parent, a Sibling or a Child. +# ------------------------------------------------------------------------------ + +sub _report_merges { + my ($self, $branch, $relation) = @_; + + my $indent = ($relation eq 'Parent') ? '' : ' '; + my $separator = ($relation eq 'Parent') ? ('-' x 80) : (' ' . '-' x 78); + $separator .= "\n"; + + my $return = ''; + + # Report last merges into/from the $branch + # ---------------------------------------------------------------------------- + my %merge = ( + 'Last Merge From ' . $relation . ':' + => [$self->last_merge_from ($branch, 1)], + 'Last Merge Into ' . $relation . ':' + => [$branch->last_merge_from ($self, 1)], + ); + + if ($self->config->verbose) { + # Verbose mode, print the log of the merge + for my $key (keys %merge) { + next if not @{ $merge{$key} }; + + # From: target (0) is self, upper delta (1) is $branch + # Into: target (0) is $branch, upper delta (1) is self + my $t = ($key =~ /From/) ? $self : $branch; + + $return .= $indent . $key . "\n"; + $return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev); + } + + } else { + # Normal mode, print in simplified form (rREV Parent@REV) + for my $key (keys %merge) { + next if not @{ $merge{$key} }; + + # From: target (0) is self, upper delta (1) is $branch + # Into: target (0) is $branch, upper delta (1) is self + $return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' . + $merge{$key}[1]->path_peg . ' cf. ' . + $merge{$key}[2]->path_peg . "\n"; + } + } + + if ($relation eq 'Sibling') { + # For sibling, do not report further if there is no recent merge + my @values = values %merge; + + return $return unless (@{ $values[0] } or @{ $values[1] }); + } + + # Report available merges into/from the $branch + # ---------------------------------------------------------------------------- + my %avail = ( + 'Merges Avail From ' . $relation . ':' + => ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]), + 'Merges Avail Into ' . $relation . ':' + => [$branch->avail_merge_from ($self, 1)], + ); + + if ($self->config->verbose) { + # Verbose mode, print the log of each revision + for my $key (keys %avail) { + next unless @{ $avail{$key} }; + + $return .= $indent . $key . "\n"; + + my $s = ($key =~ /From/) ? $branch: $self; + + for my $rev (@{ $avail{$key} }) { + $return .= $separator . $s->display_svnlog ($rev); + } + } + + } else { + # Normal mode, print only the revisions + for my $key (keys %avail) { + next unless @{ $avail{$key} }; + + $return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n"; + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0b/0ba6199075b90ba0db9273c9f433cb24818d7cf1.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0b/0ba6199075b90ba0db9273c9f433cb24818d7cf1.svn-base new file mode 100644 index 0000000..5f3d7ff --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0b/0ba6199075b90ba0db9273c9f433cb24818d7cf1.svn-base @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Exception'; + use_ok($class); + test_constructor_empty($class); + test_normal($class); +} + +################################################################################ +# Tests empty constructor +sub test_constructor_empty { + my ($class) = @_; + my $prefix = 'empty constructor'; + my $e = $class->new(); + isa_ok($e, $class, $prefix); + isnt("$e", undef, "$prefix: as_string() not undef"); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $e = $class->new({message => 'message'}); + isa_ok($e, $class, $prefix); + is("$e", "$class: message\n", "$prefix: as_string()"); + is($e->get_message(), 'message', "$prefix: get_message()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0c/0cd1eb6ed0c5460a5fad79b8e32cfe1d084f4ff0.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0c/0cd1eb6ed0c5460a5fad79b8e32cfe1d084f4ff0.svn-base new file mode 100644 index 0000000..1eb40da --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0c/0cd1eb6ed0c5460a5fad79b8e32cfe1d084f4ff0.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::ExtractConfigComparator'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0f/0f972fe16395b53fde7cbc6d5262babd825b8613.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0f/0f972fe16395b53fde7cbc6d5262babd825b8613.svn-base new file mode 100644 index 0000000..3ee7202 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/0f/0f972fe16395b53fde7cbc6d5262babd825b8613.svn-base @@ -0,0 +1,72 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Timer +# +# DESCRIPTION +# This is a package of timer utility used by the FCM command. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Timer; + +# Standard pragma +use warnings; +use strict; + +# Exports +our (@ISA, @EXPORT, @EXPORT_OK); + +sub timestamp_command; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(timestamp_command); + +# ------------------------------------------------------------------------------ + +# Module level variables +my %cmd_start_time = (); # Command start time, (key = command, value = time) + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &Fcm::Timer::timestamp_command ($command[, $status]); +# +# DESCRIPTION +# This function returns a string adding to $command a prefix according the +# value of $status. If $status is not specified or does not match the word +# "end", the status is assumed to be "start". At "start", the prefix will +# contain the current timestamp. If $status is the word "end", the prefix +# will contain the total time taken since this function was called with the +# same $command at the "start" status. +# ------------------------------------------------------------------------------ + +sub timestamp_command { + (my $command, my $status) = @_; + + my $prefix; + if ($status and $status =~ /end/i) { + # Status is "end", insert time taken + my $lapse = time () - $cmd_start_time{$command}; + $prefix = sprintf "# Time taken: %12d s=> ", $lapse; + + } else { + # Status is "start", insert time stamp + $cmd_start_time{$command} = time; + + (my $sec, my $min, my $hour, my $mday, my $mon, my $year) = localtime; + $prefix = sprintf "# Start: %04d-%02d-%02d %02d:%02d:%02d=> ", + $year + 1900, $mon + 1, $mday, $hour, $min, $sec; + } + + return $prefix . $command . "\n"; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/10/1064200e9ed47539bab82d3ea197b17a0d273170.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/10/1064200e9ed47539bab82d3ea197b17a0d273170.svn-base new file mode 100644 index 0000000..69bf5fd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/10/1064200e9ed47539bab82d3ea197b17a0d273170.svn-base @@ -0,0 +1,13 @@ +[Desktop Entry] +Comment= +Exec=fcm gui %f +Hidden=false +Icon=wizard +MimeType=inode/directory +Name=FCM GUI +Path= +Terminal=0 +TerminalOptions= +Type=Application +X-KDE-SubstituteUID=false +X-KDE-Username= diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/10/10f53dcfdd0ee75e32374f6fd8117ca76cfdc6c1.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/10/10f53dcfdd0ee75e32374f6fd8117ca76cfdc6c1.svn-base new file mode 100644 index 0000000..0648137 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/10/10f53dcfdd0ee75e32374f6fd8117ca76cfdc6c1.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::CfgPrinter'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/12/122a8657e4fb992a989a16afc12ef26d98924966.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/12/122a8657e4fb992a989a16afc12ef26d98924966.svn-base new file mode 100644 index 0000000..7a2a0a7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/12/122a8657e4fb992a989a16afc12ef26d98924966.svn-base @@ -0,0 +1,1499 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::BuildSrc +# +# DESCRIPTION +# This is a class to group functionalities of source in a build. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +package Fcm::BuildSrc; +use base qw{Fcm::Base}; + +use Carp qw{croak}; +use Cwd qw{cwd}; +use Fcm::Build::Fortran; +use Fcm::CfgFile; +use Fcm::CfgLine; +use Fcm::Config; +use Fcm::Timer qw{timestamp_command}; +use Fcm::Util qw{find_file_in_path run_command}; +use File::Basename qw{basename dirname}; +use File::Spec; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'children', # list of children packages + 'is_updated', # is this source (or its associated settings) updated? + 'mtime', # modification time of src + 'ppmtime', # modification time of ppsrc + 'ppsrc', # full path of the pre-processed source + 'pkgname', # package name of the source + 'progname', # program unit name in the source + 'src', # full path of the source + 'type', # type of the source +); + +# List of hash property methods for this class +my @hash_properties = ( + 'dep', # dependencies + 'ppdep', # pre-process dependencies + 'rules', # make rules +); + +# Error message formats +my %ERR_MESS_OF = ( + CHDIR => '%s: cannot change directory (%s), abort', + OPEN => '%s: cannot open (%s), abort', + CLOSE_PIPE => '%s: failed (%d), abort', +); + +# Event message formats and levels +my %EVENT_SETTING_OF = ( + CHDIR => ['%s: change directory' , 2], + F_INTERFACE_NONE => ['%s: Fortran interface generation is off', 3], + GET_DEPENDENCY => ['%s: %d line(s), %d auto dependency(ies)', 3], +); + +my %RE_OF = ( + F_PREFIX => qr{ + (?: + (?:ELEMENTAL|PURE(?:\s+RECURSIVE)?|RECURSIVE(?:\s+PURE)?) + \s+ + )? + }imsx, + F_SPEC => qr{ + (?: + (?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|LOGICAL|REAL|TYPE) + (?: \s* \( .+ \) | \s* \* \d+ \s*)?? + \s+ + )? + }imsx, +); + +{ + # Returns a singleton instance of Fcm::Build::Fortran. + my $FORTRAN_UTIL; + sub _get_fortran_util { + $FORTRAN_UTIL ||= Fcm::Build::Fortran->new(); + return $FORTRAN_UTIL; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::BuildSrc->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::BuildSrc class. See +# above for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my ($class, %args) = @_; + my $self = bless(Fcm::Base->new(%args), $class); + for my $key (@scalar_properties, @hash_properties) { + $self->{$key} + = exists($args{uc($key)}) ? $args{uc($key)} + : undef + ; + } + $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + + if ($name eq 'ppsrc') { + $self->ppmtime (undef); + + } elsif ($name eq 'src') { + $self->mtime (undef); + } + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'children') { + # Reference to an empty array + $self->{$name} = []; + + } elsif ($name =~ /^(?:is_cur|pkgname|ppsrc|src)$/) { + # Empty string + $self->{$name} = ''; + + } elsif ($name eq 'mtime') { + # Modification time + $self->{$name} = (stat $self->src)[9] if $self->src; + + } elsif ($name eq 'ppmtime') { + # Modification time + $self->{$name} = (stat $self->ppsrc)[9] if $self->ppsrc; + + } elsif ($name eq 'type') { + # Attempt to get the type if src is set + $self->{$name} = $self->get_type if $self->src; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + if (not defined $self->{$name}) { + if ($name eq 'rules') { + $self->{$name} = $self->get_rules; + + } else { + $self->{$name} = {}; + } + } + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# This method returns/sets property X, all derived from src, where X is: +# base - (read-only) basename of src +# dir - (read-only) dirname of src +# ext - (read-only) file extension of src +# root - (read-only) basename of src without the file extension +# ------------------------------------------------------------------------------ + +sub base { + return &basename ($_[0]->src); +} + +# ------------------------------------------------------------------------------ + +sub dir { + return &dirname ($_[0]->src); +} + +# ------------------------------------------------------------------------------ + +sub ext { + return substr $_[0]->base, length ($_[0]->root); +} + +# ------------------------------------------------------------------------------ + +sub root { + (my $root = $_[0]->base) =~ s/\.\w+$//; + return $root; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# This method returns/sets property X, all derived from ppsrc, where X is: +# ppbase - (read-only) basename of ppsrc +# ppdir - (read-only) dirname of ppsrc +# ppext - (read-only) file extension of ppsrc +# pproot - (read-only) basename of ppsrc without the file extension +# ------------------------------------------------------------------------------ + +sub ppbase { + return &basename ($_[0]->ppsrc); +} + +# ------------------------------------------------------------------------------ + +sub ppdir { + return &dirname ($_[0]->ppsrc); +} + +# ------------------------------------------------------------------------------ + +sub ppext { + return substr $_[0]->ppbase, length ($_[0]->pproot); +} + +# ------------------------------------------------------------------------------ + +sub pproot { + (my $root = $_[0]->ppbase) =~ s/\.\w+$//; + return $root; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# +# DESCRIPTION +# This method returns/sets property X, derived from src or ppsrc, where X is: +# curbase - (read-only) basename of cursrc +# curdir - (read-only) dirname of cursrc +# curext - (read-only) file extension of cursrc +# curmtime - (read-only) modification time of cursrc +# curroot - (read-only) basename of cursrc without the file extension +# cursrc - ppsrc or src +# ------------------------------------------------------------------------------ + +for my $name (qw/base dir ext mtime root src/) { + no strict 'refs'; + + my $subname = 'cur' . $name; + + *$subname = sub { + my $self = shift; + my $method = $self->ppsrc ? 'pp' . $name : $name; + return $self->$method (@_); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $base = $obj->X (); +# +# DESCRIPTION +# This method returns a basename X for the source, where X is: +# donebase - "done" file name +# etcbase - target for copying data files +# exebase - executable name for source containing a main program +# interfacebase - Fortran interface file name +# libbase - library file name +# objbase - object name for source containing compilable source +# If the source file contains a compilable procedure, this method returns +# the name of the object file. +# ------------------------------------------------------------------------------ + +sub donebase { + my $self = shift; + + my $return; + if ($self->is_type_all ('SOURCE')) { + if ($self->objbase and not $self->is_type_all ('PROGRAM')) { + $return = ($self->progname ? $self->progname : lc ($self->curroot)) . + $self->setting (qw/OUTFILE_EXT DONE/); + } + + } elsif ($self->is_type_all ('INCLUDE')) { + $return = $self->curbase . $self->setting (qw/OUTFILE_EXT IDONE/); + } + + return $return; +} + +# ------------------------------------------------------------------------------ + +sub etcbase { + my $self = shift; + + my $return = @{ $self->children } + ? $self->pkgname . $self->setting (qw/OUTFILE_EXT ETC/) + : undef; + + return $return; +} + +# ------------------------------------------------------------------------------ + +sub exebase { + my $self = shift; + + my $return; + if ($self->objbase and $self->is_type_all ('PROGRAM')) { + if ($self->setting ('BLD_EXE_NAME', $self->curroot)) { + $return = $self->setting ('BLD_EXE_NAME', $self->curroot); + + } else { + $return = $self->curroot . $self->setting (qw/OUTFILE_EXT EXE/); + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ + +sub interfacebase { + my $self = shift(); + if ( + defined($self->get_setting(qw/TOOL GENINTERFACE/)) + && uc($self->get_setting(qw/TOOL GENINTERFACE/)) ne 'NONE' + && $self->progname() + && $self->is_type_all(qw/SOURCE/) + && $self->is_type_any(qw/FORTRAN9X FPP9X/) + && !$self->is_type_any(qw/PROGRAM MODULE BLOCKDATA/) + ) { + my $flag = lc($self->get_setting(qw/TOOL INTERFACE/)); + my $ext = $self->setting(qw/OUTFILE_EXT INTERFACE/); + + return (($flag eq 'program' ? $self->progname() : $self->curroot()) . $ext); + } + return; +} + +# ------------------------------------------------------------------------------ + +sub objbase { + my $self = shift; + + my $return; + + if ($self->is_type_all ('SOURCE')) { + my $ext = $self->setting (qw/OUTFILE_EXT OBJ/); + + if ($self->is_type_any (qw/FORTRAN FPP/)) { + $return = lc ($self->progname) . $ext if $self->progname; + + } else { + $return = lc ($self->curroot) . $ext; + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->flagsbase ($flag, [$index,]); +# +# DESCRIPTION +# This method returns the property flagsbase (derived from pkgname) the base +# name of the flags-file (to indicate changes in a particular build tool) for +# $flag, which can have the value: +# *FLAGS - compiler flags flags-file +# *PPKEYS - pre-processor keys (i.e. macro definitions) flags-file +# LD - linker flags-file +# LDFLAGS - linker flags flags-file +# If $index is set, the $index'th element in pkgnames is used for the package +# name. +# ------------------------------------------------------------------------------ + +sub flagsbase { + my ($self, $flag, $index) = @_; + + (my $pkg = $index ? $self->pkgnames->[$index] : $self->pkgname) =~ s/\.\w+$//; + + if ($self->is_type_all ('SOURCE')) { + if ($flag eq 'FLAGS' or $flag eq 'PPKEYS' and $self->lang) { + my %tool_src = %{ $self->setting ('TOOL_SRC') }; + $flag = $tool_src{$self->lang}{$flag} ? $tool_src{$self->lang}{$flag} : ''; + } + } + + if ($flag) { + return join ('__', ($flag, $pkg ? $pkg : ())) . + $self->setting (qw/OUTFILE_EXT FLAGS/); + + } else { + return undef; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->libbase ([$prefix], [$suffix]); +# +# DESCRIPTION +# This method returns the property libbase (derived from pkgname) the base +# name of the library archive. $prefix and $suffix defaults to 'lib' and '.a' +# respectively. +# ------------------------------------------------------------------------------ + +sub libbase { + my ($self, $prefix, $suffix) = @_; + $prefix ||= 'lib'; + $suffix ||= $self->setting(qw/OUTFILE_EXT LIB/); + if ($self->src()) { # applies to directories only + return; + } + my $name = $self->setting('BLD_LIB', $self->pkgname()); + if (!defined($name)) { + $name = $self->pkgname(); + } + $prefix . $name . $suffix; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->lang ([$setting]); +# +# DESCRIPTION +# This method returns the property lang (derived from type) the programming +# language name if type matches one supported in the TOOL_SRC setting. If +# $setting is specified, use $setting instead of TOOL_SRC. +# ------------------------------------------------------------------------------ + +sub lang { + my ($self, $setting) = @_; + + my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') }; + + my $return = undef; + for my $key (@keys) { + next unless $self->is_type_all ('SOURCE', $key); + $return = $key; + last; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->pkgnames; +# +# DESCRIPTION +# This method returns a list of container packages, derived from pkgname: +# ------------------------------------------------------------------------------ + +sub pkgnames { + my $self = shift; + + my $return = []; + if ($self->pkgname) { + my @names = split (/__/, $self->pkgname); + + for my $i (0 .. $#names) { + push @$return, join ('__', (@names[0 .. $i])); + } + + unshift @$return, ''; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %dep = %{$obj->get_dep()}; +# %dep = %{$obj->get_dep($flag)}; +# +# DESCRIPTION +# This method scans the current source file for dependencies and returns the +# dependency hash (keys = dependencies, values = dependency types). If $flag +# is specified, the config setting for $flag is used to determine the types of +# types. Otherwise, those specified in 'BLD_TYPE_DEP' is used. +# ------------------------------------------------------------------------------ + +sub get_dep { + my ($self, $flag) = @_; + # Work out list of exclude for this file, using its sub-package name + my %EXCLUDE_SET = map {($_, 1)} @{$self->get_setting('BLD_DEP_EXCL')}; + # Determine what dependencies are supported by this known type + my %DEP_TYPE_OF = %{$self->setting($flag ? $flag : 'BLD_TYPE_DEP')}; + my %PATTERN_OF = %{$self->setting('BLD_DEP_PATTERN')}; + my @dep_types = (); + if (!$self->get_setting('BLD_DEP_N')) { + DEP_TYPE: + while (my ($key, $dep_type_string) = each(%DEP_TYPE_OF)) { + # Check if current file is a type of file requiring dependency scan + if (!$self->is_type_all($key)) { + next DEP_TYPE; + } + # Get list of dependency type for this file + for my $dep_type (split(/$Fcm::Config::DELIMITER/, $dep_type_string)) { + if (exists($PATTERN_OF{$dep_type}) && !exists($EXCLUDE_SET{$dep_type})) { + push(@dep_types, $dep_type); + } + } + } + } + + # Automatic dependencies + my %dep_of; + my $can_get_symbol # Also scan for program unit name in Fortran source + = !$flag + && $self->is_type_all('SOURCE') + && $self->is_type_any(qw/FPP FORTRAN/) + ; + my $has_read_file; + if ($can_get_symbol || @dep_types) { + my $handle = _open($self->cursrc()); + LINE: + while (my $line = readline($handle)) { + chomp($line); + if ($line =~ qr{\A \s* \z}msx) { # empty lines + next LINE; + } + if ($can_get_symbol) { + my $symbol = _get_dep_symbol($line); + if ($symbol) { + $self->progname($symbol); + $can_get_symbol = 0; + next LINE; + } + } + DEP_TYPE: + for my $dep_type (@dep_types) { + my ($match) = $line =~ /$PATTERN_OF{$dep_type}/i; + if (!$match) { + next DEP_TYPE; + } + # $match may contain multiple items delimited by space + for my $item (split(qr{\s+}msx, $match)) { + my $key = uc($dep_type . $Fcm::Config::DELIMITER . $item); + if (!exists($EXCLUDE_SET{$key})) { + $dep_of{$item} = $dep_type; + } + } + next LINE; + } + } + $self->_event('GET_DEPENDENCY', $self->pkgname(), $., scalar(keys(%dep_of))); + close($handle); + $has_read_file = 1; + } + + # Manual dependencies + my $manual_deps_ref + = $self->setting('BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname()); + if (defined($manual_deps_ref)) { + for (@{$manual_deps_ref}) { + my ($dep_type, $item) = split(/$Fcm::Config::DELIMITER/, $_, 2); + $dep_of{$item} = $dep_type; + } + } + + return ($has_read_file, \%dep_of); +} + +# Returns, if possible, the program unit declared in the $line. +sub _get_dep_symbol { + my $line = shift(); + for my $pattern ( + qr{\A \s* $RE_OF{F_PREFIX} SUBROUTINE \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* MODULE (?!\s+PROCEDURE) \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* PROGRAM \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* $RE_OF{F_PREFIX} $RE_OF{F_SPEC} FUNCTION \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* BLOCK\s*DATA \s+ ([A-Za-z]\w*)}imsx, + ) { + my ($match) = $line =~ $pattern; + if ($match) { + return lc($match); + } + } + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @out = @{ $obj->get_fortran_interface () }; +# +# DESCRIPTION +# This method invokes the Fortran interface block generator to generate +# an interface block for the current source file. It returns a reference to +# an array containing the lines of the interface block. +# ------------------------------------------------------------------------------ + +sub get_fortran_interface { + my $self = shift(); + my %ACTION_OF = ( + q{} => \&_get_fortran_interface_by_internal_code, + f90aib => \&_get_fortran_interface_by_f90aib, + none => sub {$self->_event('F_INTERFACE_NONE', $self->root()); []}, + ); + my $key = lc($self->get_setting(qw/TOOL GENINTERFACE/)); + if (!$key || !exists($ACTION_OF{$key})) { + $key = q{}; + } + $ACTION_OF{$key}->($self->cursrc()); +} + +# Generates Fortran interface block using "f90aib". +sub _get_fortran_interface_by_f90aib { + my $path = shift(); + my $command = sprintf(q{f90aib <'%s' 2>'%s'}, $path, File::Spec->devnull()); + my $pipe = _open($command, '-|'); + my @lines = readline($pipe); + close($pipe) || croak($ERR_MESS_OF{CLOSE_PIPE}, $command, $?); + \@lines; +} + +# Generates Fortran interface block using internal code. +sub _get_fortran_interface_by_internal_code { + my $path = shift(); + my $handle = _open($path); + my @lines = _get_fortran_util()->extract_interface($handle); + close($handle); + \@lines; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @out = @{ $obj->get_pre_process () }; +# +# DESCRIPTION +# This method invokes the pre-processor on the source file and returns a +# reference to an array containing the lines of the pre-processed source on +# success. +# ------------------------------------------------------------------------------ + +sub get_pre_process { + my $self = shift; + + # Supported source files + my $lang = $self->lang ('TOOL_SRC_PP'); + return unless $lang; + + # List of include directories + my @inc = @{ $self->setting (qw/PATH INC/) }; + + # Build the pre-processor command according to file type + my %tool = %{ $self->setting ('TOOL') }; + my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) }; + + # The pre-processor command and its options + my @command = ($tool{$tool_src_pp{COMMAND}}); + my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS}); + + # List of defined macros, add "-D" in front of each macro + my @ppkeys = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS}); + @ppkeys = map {($tool{$tool_src_pp{DEFINE}} . $_)} @ppkeys; + + # Add "-I" in front of each include directories + @inc = map {($tool{$tool_src_pp{INCLUDE}} . $_)} @inc; + + push @command, (@ppflags, @ppkeys, @inc, $self->base); + + # Change to container directory of source file + my $old_cwd = $self->_chdir($self->dir()); + + # Execute the command, getting the output lines + my $verbose = $self->verbose; + my @outlines = &run_command ( + \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2, + ); + + # Change back to original directory + $self->_chdir($old_cwd); + + return \@outlines; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rules = %{ $self->get_rules }; +# +# DESCRIPTION +# This method returns a reference to a hash in the following format: +# $rules = { +# target => {ACTION => action, DEP => [dependencies], ...}, +# ... => {...}, +# }; +# where the 1st rank keys are the available targets for building this source +# file, the second rank keys are ACTION and DEP. The value of ACTION is the +# action for building the target, which can be "COMPILE", "LOAD", "TOUCH", +# "CP" or "AR". The value of DEP is a refernce to an array containing a list +# of dependencies suitable for insertion into the Makefile. +# ------------------------------------------------------------------------------ + +sub get_rules { + my $self = shift; + + my $rules; + my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') }; + + if ($self->is_type_all (qw/SOURCE/)) { + # Source file + # -------------------------------------------------------------------------- + # Determine whether the language of the source file is supported + my %tool_src = %{ $self->setting ('TOOL_SRC') }; + + return () unless $self->lang; + + # Compile object + # -------------------------------------------------------------------------- + if ($self->objbase) { + # Depends on the source file + my @dep = ($self->rule_src); + + # Depends on the compiler flags flags-file + my @flags; + push @flags, ('FLAGS' ) + if $self->flagsbase ('FLAGS' ); + push @flags, ('PPKEYS') + if $self->flagsbase ('PPKEYS') and not $self->ppsrc; + + push @dep, $self->flagsbase ($_) for (@flags); + + # Source file dependencies + for my $name (sort keys %{ $self->dep }) { + # A Fortran 9X module, lower case object file name + if ($self->dep ($name) eq 'USE') { + (my $root = $name) =~ s/\.\w+$//; + push @dep, lc ($root) . $outfile_ext{OBJ}; + + # An include file + } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) { + push @dep, $name; + } + } + + $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep}; + + # Touch flags-files + # ------------------------------------------------------------------------ + for my $flag (@flags) { + next unless $self->flagsbase ($flag); + + $rules->{$self->flagsbase ($flag)} = { + ACTION => 'TOUCH', + DEP => [ + $self->flagsbase ($tool_src{$self->lang}{$flag}, -2), + ], + DEST => '$(FCM_FLAGSDIR)', + }; + } + } + + if ($self->exebase) { + # Link into an executable + # ------------------------------------------------------------------------ + my @dep = (); + push @dep, $self->objbase if $self->objbase; + push @dep, $self->flagsbase ('LD' ) if $self->flagsbase ('LD' ); + push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS'); + + # Depends on BLOCKDATA program units, for Fortran programs + my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') }; + my @blkobj = (); + + if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) { + # List of BLOCKDATA object files + if (exists $blockdata{$self->exebase}) { + @blkobj = split /\s+/, $blockdata{$self->exebase}; + + } elsif (exists $blockdata{''}) { + @blkobj = split /\s+/, $blockdata{''}; + } + + for my $name (@blkobj) { + (my $root = $name) =~ s/\.\w+$//; + $name = $root . $outfile_ext{OBJ}; + push @dep, $root . $outfile_ext{DONE}; + } + } + + # Extra executable dependencies + my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') }; + if (keys %exe_dep) { + my @exe_deps; + if (exists $exe_dep{$self->exebase}) { + @exe_deps = split /\s+/, $exe_dep{$self->exebase}; + + } elsif (exists $exe_dep{''}) { + @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : (''); + } + + my $pattern = '\\' . $outfile_ext{OBJ} . '$'; + + for my $name (@exe_deps) { + if ($name =~ /$pattern/) { + # Extra dependency is an object + (my $root = $name) =~ s/\.\w+$//; + push @dep, $root . $outfile_ext{DONE}; + + } else { + # Extra dependency is a sub-package + my $var; + if ($self->setting ('FCM_PCK_OBJECTS', $name)) { + # sub-package name contains unusual characters + $var = $self->setting ('FCM_PCK_OBJECTS', $name); + + } else { + # sub-package name contains normal characters + $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS'; + } + + push @dep, '$(' . $var . ')'; + } + } + } + + # Source file dependencies + for my $name (sort keys %{ $self->dep }) { + (my $root = $name) =~ s/\.\w+$//; + + # Lowercase name for object dependency + $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/; + + # Select "done" file extension + if ($self->dep ($name) =~ /^(?:INC|H)$/) { + push @dep, $name . $outfile_ext{IDONE}; + + } else { + push @dep, $root . $outfile_ext{DONE}; + } + } + + $rules->{$self->exebase} = { + ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj, + }; + + # Touch Linker flags-file + # ------------------------------------------------------------------------ + for my $flag (qw/LD LDFLAGS/) { + $rules->{$self->flagsbase ($flag)} = { + ACTION => 'TOUCH', + DEP => [$self->flagsbase ($flag, -2)], + DEST => '$(FCM_FLAGSDIR)', + }; + } + + } + + if ($self->donebase) { + # Touch done file + # ------------------------------------------------------------------------ + my @dep = ($self->objbase); + + for my $name (sort keys %{ $self->dep }) { + (my $root = $name) =~ s/\.\w+$//; + + # Lowercase name for object dependency + $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/; + + # Select "done" file extension + if ($self->dep ($name) =~ /^(?:INC|H)$/) { + push @dep, $name . $outfile_ext{IDONE}; + + } else { + push @dep, $root . $outfile_ext{DONE}; + } + } + + $rules->{$self->donebase} = { + ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)', + }; + } + + if ($self->interfacebase) { + # Interface target + # ------------------------------------------------------------------------ + # Source file dependencies + my @dep = (); + for my $name (sort keys %{ $self->dep }) { + # Depends on Fortran 9X modules + push @dep, lc ($name) . $outfile_ext{OBJ} + if $self->dep ($name) eq 'USE'; + } + + $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep}; + } + + } elsif ($self->is_type_all ('INCLUDE')) { + # Copy include target + # -------------------------------------------------------------------------- + my @dep = ($self->rule_src); + + for my $name (sort keys %{ $self->dep }) { + # A Fortran 9X module, lower case object file name + if ($self->dep ($name) eq 'USE') { + (my $root = $name) =~ s/\.\w+$//; + push @dep, lc ($root) . $outfile_ext{OBJ}; + + # An include file + } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) { + push @dep, $name; + } + } + + $rules->{$self->curbase} = { + ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)', + }; + + # Touch IDONE file + # -------------------------------------------------------------------------- + if ($self->donebase) { + my @dep = ($self->rule_src); + + for my $name (sort keys %{ $self->dep }) { + (my $root = $name) =~ s/\.\w+$//; + + # Lowercase name for object dependency + $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/; + + # Select "done" file extension + if ($self->dep ($name) =~ /^(?:INC|H)$/) { + push @dep, $name . $outfile_ext{IDONE}; + + } else { + push @dep, $root . $outfile_ext{DONE}; + } + } + + $rules->{$self->donebase} = { + ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)', + }; + } + + } elsif ($self->is_type_any (qw/EXE SCRIPT/)) { + # Copy executable file + # -------------------------------------------------------------------------- + my @dep = ($self->rule_src); + + # Depends on dummy copy file, if file is an "always build type" + push @dep, $self->setting (qw/BLD_CPDUMMY/) + if $self->is_type_any (split ( + /$Fcm::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD') + )); + + # Depends on other executable files + for my $name (sort keys %{ $self->dep }) { + push @dep, $name if $self->dep ($name) eq 'EXE'; + } + + $rules->{$self->curbase} = { + ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)', + }; + + } elsif (@{ $self->children }) { + # Targets for top level and package flags files and dummy dependencies + # -------------------------------------------------------------------------- + my %tool_src = %{ $self->setting ('TOOL_SRC') }; + my %flags_tool = (LD => '', LDFLAGS => ''); + + for my $key (keys %tool_src) { + $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND} + if exists $tool_src{$key}{FLAGS}; + + $flags_tool{$tool_src{$key}{PPKEYS}} = '' + if exists $tool_src{$key}{PPKEYS}; + } + + for my $name (sort keys %flags_tool) { + my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2); + push @dep, $self->flagsbase ($flags_tool{$name}) + if $self->pkgname eq '' and $flags_tool{$name}; + + $rules->{$self->flagsbase ($flags_tool{$name})} = { + ACTION => 'TOUCH', + DEST => '$(FCM_FLAGSDIR)', + } if $self->pkgname eq '' and $flags_tool{$name}; + + $rules->{$self->flagsbase ($name)} = { + ACTION => 'TOUCH', + DEP => \@dep, + DEST => '$(FCM_FLAGSDIR)', + }; + } + + # Package object and library + # -------------------------------------------------------------------------- + { + my @dep; + # Add objects from children + for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) { + push @dep, $child->rule_obj_var (1) + if $child->libbase and $child->rules ($child->libbase); + push @dep, $child->objbase + if $child->cursrc and $child->objbase and + not $child->is_type_any (qw/PROGRAM BLOCKDATA/); + } + + if (@dep) { + $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep}; + } + } + + # Package data files + # -------------------------------------------------------------------------- + { + my @dep; + for my $child (@{ $self->children }) { + push @dep, $child->rule_src if $child->src and not $child->type; + } + + if (@dep) { + push @dep, $self->setting (qw/BLD_CPDUMMY/); + $rules->{$self->etcbase} = { + ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)', + }; + } + } + } + + return $rules; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->get_setting ($setting[, @prefix]); +# +# DESCRIPTION +# This method gets the correct $setting for the current source by following +# its package name. If @prefix is set, get the setting with the given prefix. +# ------------------------------------------------------------------------------ + +sub get_setting { + my ($self, $setting, @prefix) = @_; + + my $val; + for my $name (reverse @{ $self->pkgnames }) { + my @names = split /__/, $name; + $val = $self->setting ($setting, join ('__', (@prefix, @names))); + + $val = $self->setting ($setting, join ('__', (@prefix, @names))) + if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//; + last if defined $val; + } + + return $val; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $type = $self->get_type(); +# +# DESCRIPTION +# This method determines whether the source is a type known to the +# build system. If so, it returns the type flags delimited by "::". +# ------------------------------------------------------------------------------ + +sub get_type { + my $self = shift(); + my @IGNORE_LIST + = split(/$Fcm::Config::DELIMITER_LIST/, $self->setting('INFILE_IGNORE')); + if (grep {$self->curbase() eq $_} @IGNORE_LIST) { + return q{}; + } + # User defined + my $type = $self->setting('BLD_TYPE', $self->pkgname()); + # Extension + if (!defined($type)) { + my $ext = $self->curext() ? substr($self->curext(), 1) : q{}; + $type = $self->setting('INFILE_EXT', $ext); + } + # Pattern of name + if (!defined($type)) { + my %NAME_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_PAT')}; + PATTERN: + while (my ($pattern, $value) = each(%NAME_PATTERN_TO_TYPE_HASH)) { + if ($self->curbase() =~ $pattern) { + $type = $value; + last PATTERN; + } + } + } + # Pattern of #! line + if (!defined($type) && -s $self->cursrc() && -T _) { + my $handle = _open($self->cursrc()); + my $line = readline($handle); + close($handle); + my %SHEBANG_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_TXT')}; + PATTERN: + while (my ($pattern, $value) = each(%SHEBANG_PATTERN_TO_TYPE_HASH)) { + if ($line =~ qr{^\#!.*$pattern}msx) { + $type = $value; + last PATTERN; + } + } + } + if (!$type) { + return $type; + } + # Extra type information for selected file types + my %EXTRA_FOR = ( + qr{\b (?:FORTRAN|FPP) \b}msx => \&_get_type_extra_for_fortran, + qr{\b C \b}msx => \&_get_type_extra_for_c, + ); + EXTRA: + while (my ($key, $code_ref) = each(%EXTRA_FOR)) { + if ($type =~ $key) { + my $handle = _open($self->cursrc()); + LINE: + while (my $line = readline($handle)) { + my $extra = $code_ref->($line); + if ($extra) { + $type .= $Fcm::Config::DELIMITER . $extra; + last LINE; + } + } + close($handle); + last EXTRA; + } + } + return $type; +} + +sub _get_type_extra_for_fortran { + my ($match) = $_[0] =~ qr{\A \s* (PROGRAM|MODULE|BLOCK\s*DATA) \b}imsx; + if (!$match) { + return; + } + $match =~ s{\s}{}g; + uc($match) +} + +sub _get_type_extra_for_c { + ($_[0] =~ qr{int\s+main\s*\(}msx) ? 'PROGRAM' : undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->is_in_package ($name); +# +# DESCRIPTION +# This method returns true if current package is in the package $name. +# ------------------------------------------------------------------------------ + +sub is_in_package { + my ($self, $name) = @_; + + my $return = 0; + for (@{ $self->pkgnames }) { + next unless /^$name(?:\.\w+)?$/; + $return = 1; + last; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->is_type_all ($arg, ...); +# $flag = $obj->is_type_any ($arg, ...); +# +# DESCRIPTION +# This method returns a flag for the following: +# is_type_all - does type match all of the arguments? +# is_type_any - does type match any of the arguments? +# ------------------------------------------------------------------------------ + +for my $name ('all', 'any') { + no strict 'refs'; + + my $subname = 'is_type_' . $name; + + *$subname = sub { + my ($self, @intypes) = @_; + + my $rc = 0; + if ($self->type) { + my %types = map {($_, 1)} split /$Fcm::Config::DELIMITER/, $self->type; + + for my $intype (@intypes) { + $rc = exists $types{$intype}; + last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc); + } + } + + return $rc; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->rule_obj_var ([$read]); +# +# DESCRIPTION +# This method returns a string containing the make rule object variable for +# the current package. If $read is set, return $($string) +# ------------------------------------------------------------------------------ + +sub rule_obj_var { + my ($self, $read) = @_; + + my $return; + if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) { + # Package name registered in unusual list + $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname); + + } else { + # Package name not registered in unusual list + $return = $self->pkgname + ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS'; + } + + $return = $read ? '$(' . $return . ')' : $return; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->rule_src (); +# +# DESCRIPTION +# This method returns a string containing the location of the source file +# relative to the build root. This string will be suitable for use in a +# "Make" rule file for FCM. +# ------------------------------------------------------------------------------ + +sub rule_src { + my $self = shift; + + my $return = $self->cursrc; + LABEL: for my $name (qw/SRC PPSRC/) { + for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) { + my $dir = $self->setting ('PATH', $name)->[$i]; + next unless index ($self->cursrc, $dir) == 0; + + $return = File::Spec->catfile ( + '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')', + File::Spec->abs2rel ($self->cursrc, $dir), + ); + last LABEL; + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->write_lib_dep_excl (); +# +# DESCRIPTION +# This method writes a set of exclude dependency configurations for the +# library of this package. +# ------------------------------------------------------------------------------ + +sub write_lib_dep_excl { + my $self = shift(); + if (!find_file_in_path($self->libbase(), $self->setting(qw/PATH LIB/))) { + return 0; + } + + my $ETC_DIR = $self->setting(qw/PATH ETC/)->[0]; + my $CFG_EXT = $self->setting(qw/OUTFILE_EXT CFG/); + my $LABEL_OF_EXCL_DEP = $self->cfglabel('BLD_DEP_EXCL'); + my @SETTINGS = ( + #dependency #source file type list #dependency name function + ['H' , [qw{INCLUDE CPP }], sub {$_[0]->base()} ], + ['INTERFACE', [qw{INCLUDE INTERFACE }], sub {$_[0]->base()} ], + ['INC' , [qw{INCLUDE }], sub {$_[0]->base()} ], + ['USE' , [qw{SOURCE FORTRAN MODULE}], sub {$_[0]->root()} ], + ['INTERFACE', [qw{SOURCE FORTRAN }], sub {$_[0]->interfacebase()}], + ['OBJ' , [qw{SOURCE }], sub {$_[0]->root()} ], + ); + + my $cfg = Fcm::CfgFile->new(); + my @stack = ($self); + NODE: + while (my $node = pop(@stack)) { + # Is a directory + if (@{$node->children()}) { + push(@stack, reverse(@{$node->children()})); + next NODE; + } + # Is a typed file + if ( + $node->cursrc() + && $node->type() + && !$node->is_type_any(qw{PROGRAM BLOCKDATA}) + ) { + for (@SETTINGS) { + my ($key, $type_list_ref, $name_func_ref) = @{$_}; + my $name = $name_func_ref->($node); + if ($name && $node->is_type_all(@{$type_list_ref})) { + push( + @{$cfg->lines()}, + Fcm::CfgLine->new( + label => $LABEL_OF_EXCL_DEP, + value => $key . $Fcm::Config::DELIMITER . $name, + ), + ); + next NODE; + } + } + } + } + + # Write to configuration file + $cfg->print_cfg( + File::Spec->catfile($ETC_DIR, $self->libbase('lib', $CFG_EXT)), + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->write_rules (); +# +# DESCRIPTION +# This method returns a string containing the "Make" rules for building the +# source file. +# ------------------------------------------------------------------------------ + +sub write_rules { + my $self = shift; + my $mk = ''; + + for my $target (sort keys %{ $self->rules }) { + my $rule = $self->rules ($target); + next unless defined ($rule->{ACTION}); + + if ($rule->{ACTION} eq 'AR') { + my $var = $self->rule_obj_var; + $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' ='; + $mk .= ' ' . join (' ', @{ $rule->{DEP} }); + $mk .= "\n\n"; + } + + $mk .= $target . ':'; + + if ($rule->{ACTION} eq 'AR') { + $mk .= ' ' . $self->rule_obj_var (1); + + } else { + for my $dep (@{ $rule->{DEP} }) { + $mk .= ' ' . $dep; + } + } + + $mk .= "\n"; + + if (exists $rule->{ACTION}) { + if ($rule->{ACTION} eq 'AR') { + $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n"; + + } elsif ($rule->{ACTION} eq 'CP') { + $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n"; + $mk .= "\t" . 'chmod u+w ' . + File::Spec->catfile ($rule->{DEST}, '$@') . "\n"; + + } elsif ($rule->{ACTION} eq 'CP_DATA') { + $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n"; + $mk .= "\t" . 'touch ' . + File::Spec->catfile ($rule->{DEST}, '$@') . "\n"; + + } elsif ($rule->{ACTION} eq 'COMPILE') { + if ($self->lang) { + $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) . + ' ' . $self->pkgnames->[-2] . ' $< $@'; + $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc); + $mk .= "\n"; + } + + } elsif ($rule->{ACTION} eq 'LOAD') { + if ($self->lang) { + $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) . + ' ' . $self->pkgnames->[-2] . ' $< $@'; + $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} }) + if @{ $rule->{BLOCKDATA} }; + $mk .= "\n"; + } + + } elsif ($rule->{ACTION} eq 'TOUCH') { + $mk .= "\t" . 'touch ' . + File::Spec->catfile ($rule->{DEST}, '$@') . "\n"; + } + } + + $mk .= "\n"; + } + + return $mk; +} + +# Wraps "chdir". Returns old directory. +sub _chdir { + my ($self, $dir) = @_; + my $old_cwd = cwd(); + $self->_event('CHDIR', $dir); + chdir($dir) || croak(sprintf($ERR_MESS_OF{CHDIR}, $dir)); + $old_cwd; +} + +# Wraps an event. +sub _event { + my ($self, $key, @args) = @_; + my ($format, $level) = @{$EVENT_SETTING_OF{$key}}; + $level ||= 1; + if ($self->verbose() >= $level) { + printf($format . ".\n", @args); + } +} + +# Wraps "open". +sub _open { + my ($path, $mode) = @_; + $mode ||= '<'; + open(my $handle, $mode, $path) || croak(sprintf($ERR_MESS_OF{OPEN}, $path, $!)); + $handle; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/13/13e33d1f5f81527a1a902a1f469a2b16f1514772.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/13/13e33d1f5f81527a1a902a1f469a2b16f1514772.svn-base new file mode 100644 index 0000000..5a64cf6 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/13/13e33d1f5f81527a1a902a1f469a2b16f1514772.svn-base @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Exception'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $e = $class->new({message => 'message'}); + isa_ok($e, $class, $prefix); + is("$e", "$class: message\n", "$prefix: as_string()"); + is($e->get_message(), 'message', "$prefix: get_message()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/17/17f4b9bd2c588ce8914f138b55ec7bb133b5a16f.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/17/17f4b9bd2c588ce8914f138b55ec7bb133b5a16f.svn-base new file mode 100644 index 0000000..847263f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/17/17f4b9bd2c588ce8914f138b55ec7bb133b5a16f.svn-base @@ -0,0 +1,168 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Option'; + use_ok($class); + test_simplest($class); + test_simplest_scalar_arg($class); + test_simplest_array_arg($class); + test_simplest_hash_arg($class); + test_simple($class); + test_simple_scalar_arg($class); + test_simple_array_arg($class); + test_simple_hash_arg($class); + test_long_letter($class); +} + +################################################################################ +# Tests simplest usage +sub test_simplest { + my ($class) = @_; + my $prefix = 'simplest'; + my $option = $class->new({ + delimiter => 'delimiter-value', + description => 'description value', + name => 'name-value', + }); + isa_ok($option, $class); + is($option->get_delimiter(), 'delimiter-value', "$prefix: delimiter"); + is($option->get_description(), 'description value', "$prefix: description"); + is($option->get_name(), 'name-value', "$prefix: name"); + is($option->get_letter(), undef, "$prefix: letter"); + ok(!$option->has_arg(), "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with a scalar argument +sub test_simplest_scalar_arg { + my ($class) = @_; + my $prefix = 'simplest scalar arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + has_arg => $class->SCALAR_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->SCALAR_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value=s', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with array argument +sub test_simplest_array_arg { + my ($class) = @_; + my $prefix = 'simplest array arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + has_arg => $class->ARRAY_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->ARRAY_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value=s@', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with hash argument +sub test_simplest_hash_arg { + my ($class) = @_; + my $prefix = 'simplest hash arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + has_arg => $class->HASH_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->HASH_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value=s%', "$prefix: has arg"); +} + +################################################################################ +# Tests simple usage +sub test_simple { + my ($class) = @_; + my $prefix = 'simple'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + }); + isa_ok($option, $class); + is($option->get_description(), 'description value', "$prefix: description"); + is($option->get_name(), 'name-value', "$prefix: name"); + is($option->get_letter(), 'n', "$prefix: letter"); + is($option->has_arg(), $class->NO_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n', "$prefix: has arg"); +} + +################################################################################ +# Tests simple usage with a scalar argument +sub test_simple_scalar_arg { + my ($class) = @_; + my $prefix = 'simple scalar arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + has_arg => $class->SCALAR_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->SCALAR_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n=s', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with array argument +sub test_simple_array_arg { + my ($class) = @_; + my $prefix = 'simple array arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + has_arg => $class->ARRAY_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->ARRAY_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n=s@', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with hash argument +sub test_simple_hash_arg { + my ($class) = @_; + my $prefix = 'simple hash arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + has_arg => $class->HASH_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->HASH_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n=s%', "$prefix: has arg"); +} + +################################################################################ +# Tests longer than 1 letter +sub test_long_letter { + my ($class) = @_; + my $prefix = 'long letter'; + my $option = $class->new({ + name => 'name-value', + letter => 'name', + }); + isa_ok($option, $class); + is($option->get_letter(), 'n', "$prefix: letter"); + is($option->get_arg_for_getopt_long(), 'name-value|n', "$prefix: has arg"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/18/187c071301410b9f58c5dc4d63d411a75176b4b1.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/18/187c071301410b9f58c5dc4d63d411a75176b4b1.svn-base new file mode 100644 index 0000000..0cb6514 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/18/187c071301410b9f58c5dc4d63d411a75176b4b1.svn-base @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A class for testing the loader +{ + package MyTestClass; + + sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); + } +} + +use Test::More qw{no_plan}; + +main(); + +sub main { + use_ok('Fcm::Util::ClassLoader'); + test_normal(); + test_bad(); +} + +################################################################################ +# Tests loading classes that should load OK +sub test_normal { + my $prefix = 'normal'; + my @CLASSES = ( + 'Fcm::CLI::Config', + 'Fcm::Exception', + 'Fcm::CLI::Config', # repeat + 'MyTestClass', + ); + for my $class (@CLASSES) { + ok(Fcm::Util::ClassLoader::load($class), "$prefix: load $class"); + } +} + +################################################################################ +# Tests loading classes that should fail +sub test_bad { + my $prefix = 'bad'; + my @CLASSES = ('Foo', 'Bar', 'Baz', 'No::Such::Class', 'Foo'); + for my $class (@CLASSES) { + eval { + Fcm::Util::ClassLoader::load($class); + }; + isa_ok($@, 'Fcm::Exception', "$prefix: load $class"); + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/18/188ab7b20209ed1e6151ec3789ff71e5d4720885.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/18/188ab7b20209ed1e6151ec3789ff71e5d4720885.svn-base new file mode 100644 index 0000000..5a03e44 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/18/188ab7b20209ed1e6151ec3789ff71e5d4720885.svn-base @@ -0,0 +1,183 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Option; + +use constant NO_ARG => 0; +use constant SCALAR_ARG => 1; +use constant ARRAY_ARG => 2; +use constant HASH_ARG => 3; +use constant ARG_STRING_SUFFIX_FOR => (q{}, q{=s}, q{=s@}, q{=s%}); + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + # Returns the delimiter of this option, if it is an array + 'delimiter', + # Returns the description of this option + 'description', + # Returns the (long) name of this option + 'name', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + return $self->{$key}; + } +} + +################################################################################ +# Returns the letter of this option +sub get_letter { + my ($self) = @_; + if (defined($self->{letter})) { + return substr($self->{letter}, 0, 1); + } + else { + return; + } +} + +################################################################################ +# Returns whether the current option has no, scalar, array or hash arguments +sub has_arg { + my ($self) = @_; + return (defined($self->{has_arg}) ? $self->{has_arg} : $self->NO_ARG); +} + +################################################################################ +# Returns true if this option is associated with help +sub is_help { + my ($self) = @_; + return $self->{is_help}; +} + +################################################################################ +# Returns an option string/reference pair for Getopt::Long::GetOptions +sub get_arg_for_getopt_long { + my ($self) = @_; + my $option_string + = $self->get_name() + . ($self->get_letter() ? q{|} . $self->get_letter() : q{}) + . (ARG_STRING_SUFFIX_FOR)[$self->has_arg()] + ; + return $option_string; +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Option + +=head1 SYNOPSIS + + use Fcm::CLI::Option; + $option = Fcm::CLI::Option->new({ + name => 'name', + letter => 'n', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + is_help => 1, + description => 'an example option', + }); + + # time passes ... + use Getopt::Long qw{GetOptions}; + $success = GetOptions( + \%hash, + $option->get_arg_for_getopt_long(), # ('name|n=s') + # and other options ... + ); + $option_value = $option->get_value(); + +=head1 DESCRIPTION + +An object of this class represents a CLI option. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor. + +=item get_arg_for_getopt_long() + +Returns an option string for this option that is suitable for use as arguments +to L. + +=item get_description() + +Returns a description of this option. + +=item get_delimiter() + +Returns the delimiter of this option. This is only relevant if has_arg() is +equal to C. If set, the argument for this option should be re-grouped +using this delimiter. + +=item get_name() + +Returns the (long) name of this option. + +=item get_letter() + +Returns the option letter of this option. + +=item has_arg() + +Returns whether this option has no, scalar, array or hash arguments. See +L for detail. + +=item is_help() + +Returns true if this option is associated with help. + +=back + +=head1 CONSTANTS + +=over 4 + +=item NO_ARG + +An option has no argument. (Default) + +=item SCALAR_ARG + +An option has a single scalar argument. + +=item ARRAY_ARG + +An option has multiple arguments, which can be placed in an array. + +=item HASH_ARG + +An option has multiple arguments, which can be placed in an hash. + +=back + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1a/1a83fea81ca71b6630e98d3187995cdefe97a650.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1a/1a83fea81ca71b6630e98d3187995cdefe97a650.svn-base new file mode 100644 index 0000000..58b7dd2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1a/1a83fea81ca71b6630e98d3187995cdefe97a650.svn-base @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Keyword::Entry; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Formatter::Entry'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $formatter = $class->new(); + isa_ok($formatter, $class, $prefix); + my $entry = Fcm::Keyword::Entry->new({key => 'k', value => 'v'}); + is($formatter->format($entry), "k = v\n", "$prefix: format"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1a/1aff8e2a5fccc6b462d84b0be9cab69660fa34c6.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1a/1aff8e2a5fccc6b462d84b0be9cab69660fa34c6.svn-base new file mode 100644 index 0000000..9558502 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1a/1aff8e2a5fccc6b462d84b0be9cab69660fa34c6.svn-base @@ -0,0 +1,42 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Exception; +use base qw{Fcm::Exception}; + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Exception + +=head1 SYNOPSIS + + use Carp qw{croak}; + use Fcm::Keyword::Exception; + croak(Fcm::Keyword::Exception->new({message => 'something is wrong'})); + +=head1 DESCRIPTION + +This class extends L. This exception is thrown +on errors associated with the command line interface. + +=head1 METHODS + +See L for a list of methods. + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1c/1c90b9bccdc2023d9ad95a9210aa8109afa78465.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1c/1c90b9bccdc2023d9ad95a9210aa8109afa78465.svn-base new file mode 100644 index 0000000..6231425 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1c/1c90b9bccdc2023d9ad95a9210aa8109afa78465.svn-base @@ -0,0 +1,735 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ConfigSystem +# +# DESCRIPTION +# This is the base class for FCM systems that are based on inherited +# configuration files, e.g. the extract and the build systems. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::ConfigSystem; +use base qw{Fcm::Base}; + +use strict; +use warnings; + +use Fcm::CfgFile; +use Fcm::CfgLine; +use Fcm::Dest; +use Fcm::Util qw{expand_tilde e_report w_report}; +use Sys::Hostname qw{hostname}; + +# List of property methods for this class +my @scalar_properties = ( + 'cfg', # configuration file + 'cfg_methods', # list of sub-methods for parse_cfg + 'cfg_prefix', # optional prefix in configuration declaration + 'dest', # destination for output + 'inherit', # list of inherited configurations + 'inherited', # list of inheritance hierarchy + 'type', # system type +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ConfigSystem->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ConfigSystem class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + bless $self, $class; + + # List of sub-methods for parse_cfg + $self->cfg_methods ([qw/header inherit dest/]); + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'cfg') { + # New configuration file + $self->{$name} = Fcm::CfgFile->new (TYPE => $self->type); + + } elsif ($name =~ /^(?:cfg_methods|inherit|inherited)$/) { + # Reference to an array + $self->{$name} = []; + + } elsif ($name eq 'cfg_prefix' or $name eq 'type') { + # Reference to an array + $self->{$name} = ''; + + } elsif ($name eq 'dest') { + # New destination + $self->{$name} = Fcm::Dest->new (TYPE => $self->type); + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $out_of_date) = $obj->check_cache (); +# +# DESCRIPTION +# This method returns $rc = 1 on success or undef on failure. It returns +# $out_of_date = 1 if current cache file is out of date relative to those in +# inherited runs or 0 otherwise. +# ------------------------------------------------------------------------------ + +sub check_cache { + my $self = shift; + + my $rc = 1; + my $out_of_date = 0; + + if (@{ $self->inherit } and -f $self->dest->cache) { + # Get modification time of current cache file + my $cur_mtime = (stat ($self->dest->cache))[9]; + + # Compare with modification times of inherited cache files + for my $use (@{ $self->inherit }) { + next unless -f $use->dest->cache; + my $use_mtime = (stat ($use->dest->cache))[9]; + $out_of_date = 1 if $use_mtime > $cur_mtime; + } + } + + return ($rc, $out_of_date); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->check_lock (); +# +# DESCRIPTION +# This method returns true if no lock is found in the destination or if the +# locks found are allowed. +# ------------------------------------------------------------------------------ + +sub check_lock { + my $self = shift; + + # Check all types of locks + for my $method (@Fcm::Dest::lockfiles) { + my $lock = $self->dest->$method; + + # Check whether lock exists + next unless -e $lock; + + # Check whether this lock is allowed + next if $self->check_lock_is_allowed ($lock); + + # Throw error if a lock exists + w_report 'ERROR: ', $lock, ': lock file exists,'; + w_report ' ', $self->dest->rootdir, ': destination is busy.'; + return; + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->check_lock_is_allowed ($lock); +# +# DESCRIPTION +# This method returns true if it is OK for $lock to exist in the destination. +# ------------------------------------------------------------------------------ + +sub check_lock_is_allowed { + my ($self, $lock) = @_; + + # Disallow all types of locks by default + return 0; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->compare_setting ( +# METHOD_LIST => \@method_list, +# [METHOD_ARGS => \@method_args,] +# [CACHEBASE => $cachebase,] +# ); +# +# DESCRIPTION +# This method gets settings from the previous cache and updates the current. +# +# METHOD +# The method returns true on success. @method_list must be a list of method +# names for processing the cached lines in the previous run. If an existing +# cache exists, its content is read into $old_lines, which is a list of +# Fcm::CfgLine objects. Otherwise, $old_lines is set to undef. If $cachebase +# is set, it is used for as the cache basename. Otherwise, the default for +# the current system is used. It calls each method in the @method_list using +# $self->$method ($old_lines, @method_args), which should return a +# two-element list. The first element should be a return code (1 for out of +# date, 0 for up to date and undef for failure). The second element should be +# a reference to a list of Fcm::CfgLine objects for the output. +# ------------------------------------------------------------------------------ + +sub compare_setting { + my ($self, %args) = @_; + + my @method_list = exists ($args{METHOD_LIST}) ? @{ $args{METHOD_LIST} } : (); + my @method_args = exists ($args{METHOD_ARGS}) ? @{ $args{METHOD_ARGS} } : (); + my $cachebase = exists ($args{CACHEBASE}) ? $args{CACHEBASE} : undef; + + my $rc = 1; + + # Read cache if the file exists + # ---------------------------------------------------------------------------- + my $cache = $cachebase + ? File::Spec->catfile ($self->dest->cachedir, $cachebase) + : $self->dest->cache; + my @in_caches = (); + if (-r $cache) { + push @in_caches, $cache; + + } else { + for my $use (@{ $self->inherit }) { + my $use_cache = $cachebase + ? File::Spec->catfile ($use->dest->cachedir, $cachebase) + : $use->dest->cache; + push @in_caches, $use_cache if -r $use_cache; + } + } + + my $old_lines = undef; + for my $in_cache (@in_caches) { + next unless -r $in_cache; + my $cfg = Fcm::CfgFile->new (SRC => $in_cache); + + if ($cfg->read_cfg) { + $old_lines = [] if not defined $old_lines; + push @$old_lines, @{ $cfg->lines }; + } + } + + # Call methods in @method_list to see if cache is out of date + # ---------------------------------------------------------------------------- + my @new_lines = (); + my $out_of_date = 0; + for my $method (@method_list) { + my ($return, $lines); + ($return, $lines) = $self->$method ($old_lines, @method_args) if $rc; + + if (defined $return) { + # Method succeeded + push @new_lines, @$lines; + $out_of_date = 1 if $return; + + } else { + # Method failed + $rc = $return; + last; + } + } + + # Update the cache in the current run + # ---------------------------------------------------------------------------- + if ($rc) { + if (@{ $self->inherited } and $out_of_date) { + # If this is an inherited configuration, the cache must not be changed + w_report 'ERROR: ', $self->cfg->src, + ': inherited configuration does not match with its cache.'; + $rc = undef; + + } elsif ((not -f $cache) or $out_of_date) { + my $cfg = Fcm::CfgFile->new; + $cfg->lines ([sort {$a->label cmp $b->label} @new_lines]); + $rc = $cfg->print_cfg ($cache, 1); + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($changed_hash_ref, $new_lines_array_ref) = +# $self->compare_setting_in_config($prefix, \@old_lines); +# +# DESCRIPTION +# This method compares old and current settings for a specified item. +# +# METHOD +# This method does two things. +# +# It uses the current configuration for the $prefix item to generate a list of +# new Fcm::CfgLine objects (which is returned as a reference in the second +# element of the returned list). +# +# The values of the old lines are then compared with those of the new lines. +# Any settings that are changed are stored in a hash, which is returned as a +# reference in the first element of the returned list. The key of the hash is +# the name of the changed setting, and the value is the value of the new +# setting or undef if the setting no longer exists. +# +# ARGUMENTS +# $prefix - the name of an item in Fcm::Config to be compared +# @old_lines - a list of Fcm::CfgLine objects containing the old settings +# ------------------------------------------------------------------------------ + +sub compare_setting_in_config { + my ($self, $prefix, $old_lines_ref) = @_; + + my %changed = %{$self->setting($prefix)}; + my (@new_lines, %new_val_of); + while (my ($key, $val) = each(%changed)) { + $new_val_of{$key} = (ref($val) eq 'ARRAY' ? join(q{ }, sort(@{$val})) : $val); + push(@new_lines, Fcm::CfgLine->new( + LABEL => $prefix . $Fcm::Config::DELIMITER . $key, + VALUE => $new_val_of{$key}, + )); + } + + if (defined($old_lines_ref)) { + my %old_val_of + = map {($_->label_from_field(1), $_->value())} # converts into a hash + grep {$_->label_starts_with($prefix)} # gets relevant lines + @{$old_lines_ref}; + + while (my ($key, $val) = each(%old_val_of)) { + if (exists($changed{$key})) { + if ($val eq $new_val_of{$key}) { # no change from old to new + delete($changed{$key}); + } + } + else { # exists in old but not in new + $changed{$key} = undef; + } + } + } + + return (\%changed, \@new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->invoke ([CLEAN => 1, ]%args); +# +# DESCRIPTION +# This method invokes the system. If CLEAN is set to true, it will only parse +# the configuration and set up the destination, but will not invoke the +# system. See the invoke_setup_dest and the invoke_system methods for list of +# other arguments in %args. +# ------------------------------------------------------------------------------ + +sub invoke { + my $self = shift; + my %args = @_; + + # Print diagnostic at beginning of run + # ---------------------------------------------------------------------------- + # Name of the system + (my $name = ref ($self)) =~ s/^Fcm:://; + + # Print start time on system run, if verbose is true + my $date = localtime; + print $name, ' command started on ', $date, '.', "\n" + if $self->verbose; + + # Start time (seconds since epoch) + my $otime = time; + + # Parse the configuration file + my $rc = $self->invoke_stage ('Parse configuration', 'parse_cfg'); + + # Set up the destination + $rc = $self->invoke_stage ('Setup destination', 'invoke_setup_dest', %args) + if $rc; + + # Invoke the system + # ---------------------------------------------------------------------------- + $rc = $self->invoke_system (%args) if $rc and not $args{CLEAN}; + + # Remove empty directories + $rc = $self->dest->clean (MODE => 'EMPTY') if $rc; + + # Print diagnostic at end of run + # ---------------------------------------------------------------------------- + # Print lapse time at the end, if verbose is true + if ($self->verbose) { + my $total = time - $otime; + my $s_str = $total > 1 ? 'seconds' : 'second'; + print '->TOTAL: ', $total, ' ', $s_str, "\n"; + } + + # Report end of system run + $date = localtime; + if ($rc) { + # Success + print $name, ' command finished on ', $date, '.', "\n" + if $self->verbose; + + } else { + # Failure + e_report $name, ' failed on ', $date, '.'; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->invoke_setup_dest ([CLEAN|FULL => 1], [IGNORE_LOCK => 1]); +# +# DESCRIPTION +# This method sets up the destination and returns true on success. +# +# ARGUMENTS +# CLEAN|FULL - If set to "true", set up the system in "clean|full" mode. +# Sub-directories and files in the root directory created by +# the previous invocation of the system will be removed. If +# not set, the default is to run in "incremental" mode. +# IGNORE_LOCK - If set to "true", it ignores any lock files that may exist in +# the destination root directory. +# ------------------------------------------------------------------------------ + +sub invoke_setup_dest { + my $self = shift; + my %args = @_; + + # Set up destination + # ---------------------------------------------------------------------------- + # Print destination in verbose mode + if ($self->verbose()) { + printf( + "Destination: %s@%s:%s\n", + scalar(getpwuid($<)), + hostname(), + $self->dest()->rootdir(), + ); + } + + my $rc = 1; + my $out_of_date = 0; + + # Check whether lock exists in the destination root + $rc = $self->check_lock if $rc and not $args{IGNORE_LOCK}; + + # Check whether current cache is out of date relative to the inherited ones + ($rc, $out_of_date) = $self->check_cache if $rc; + + # Remove sub-directories and files in destination in "full" mode + $rc = $self->dest->clean (MODE => 'ALL') + if $rc and ($args{FULL} or $args{CLEAN} or $out_of_date); + + # Create build root directory if necessary + $rc = $self->dest->create if $rc; + + # Set a lock in the destination root + $rc = $self->dest->set_lock if $rc; + + # Generate an as-parsed configuration file + $self->cfg->print_cfg ($self->dest->parsedcfg); + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_stage ($name, $method, @args); +# +# DESCRIPTION +# This method invokes a named stage of the system, where $name is the name of +# the stage, $method is the name of the method for invoking the stage and +# @args are the arguments to the &method. +# ------------------------------------------------------------------------------ + +sub invoke_stage { + my ($self, $name, $method, @args) = @_; + + # Print diagnostic at beginning of a stage + print '->', $name, ': start', "\n" if $self->verbose; + my $stime = time; + + # Invoke the stage + my $rc = $self->$method (@args); + + # Print diagnostic at end of a stage + my $total = time - $stime; + my $s_str = $total > 1 ? 'seconds' : 'second'; + print '->', $name, ': ', $total, ' ', $s_str, "\n"; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_system (%args); +# +# DESCRIPTION +# This is a prototype method for invoking the system. +# ------------------------------------------------------------------------------ + +sub invoke_system { + my $self = shift; + my %args = @_; + + print "Dummy code.\n"; + + return 0; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->parse_cfg (); +# +# DESCRIPTION +# This method calls other methods to parse the configuration file. +# ------------------------------------------------------------------------------ + +sub parse_cfg { + my $self = shift; + + return unless $self->cfg->src; + + # Read config file + # ---------------------------------------------------------------------------- + return unless $self->cfg->read_cfg; + + if ($self->cfg->type ne $self->type) { + w_report 'ERROR: ', $self->cfg->src, ': not a ', $self->type, + ' config file.'; + return; + } + + # Strip out optional prefix from all labels + # ---------------------------------------------------------------------------- + if ($self->cfg_prefix) { + for my $line (@{ $self->cfg->lines }) { + $line->prefix ($self->cfg_prefix); + } + } + + # Filter lines from the configuration file + # ---------------------------------------------------------------------------- + my @cfg_lines = grep { + $_->slabel and # ignore empty/comment lines + index ($_->slabel, '%') != 0 and # ignore user variable + not $_->slabel_starts_with_cfg ('INC') # ignore INC line + } @{ $self->cfg->lines }; + + # Parse the lines to read in the various settings, by calling the methods: + # $self->parse_cfg_XXX, where XXX is: header, inherit, dest, and the values + # in the list @{ $self->cfg_methods }. + # ---------------------------------------------------------------------------- + my $rc = 1; + for my $name (@{ $self->cfg_methods }) { + my $method = 'parse_cfg_' . $name; + $self->$method (\@cfg_lines) or $rc = 0; + } + + # Report warnings/errors + # ---------------------------------------------------------------------------- + for my $line (@cfg_lines) { + $rc = 0 if not $line->parsed; + my $mesg = $line->format_error; + w_report $mesg if $mesg; + } + + return ($rc); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_dest (\@cfg_lines); +# +# DESCRIPTION +# This method parses the destination settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_dest { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + + # DEST/DIR declarations + # ---------------------------------------------------------------------------- + my @lines = grep { + $_->slabel_starts_with_cfg ('DEST') or $_->slabel_starts_with_cfg ('DIR') + } @$cfg_lines; + + # Only ROOTDIR declarations are accepted + for my $line (@lines) { + my ($d, $method) = $line->slabel_fields; + $d = lc $d; + $method = lc $method; + + # Backward compatibility + $d = 'dest' if $d eq 'dir'; + + # Default to "rootdir" + $method = 'rootdir' if (not $method) or $method eq 'root'; + + # Only "rootdir" can be set + next unless $method eq 'rootdir'; + + $self->$d->$method (&expand_tilde ($line->value)); + $line->parsed (1); + } + + # Make sure root directory is set + # ---------------------------------------------------------------------------- + if (not $self->dest->rootdir) { + w_report 'ERROR: ', $self->cfg->actual_src, + ': destination root directory not set.'; + $rc = 0; + } + + # Inherit destinations + # ---------------------------------------------------------------------------- + for my $use (@{ $self->inherit }) { + push @{ $self->dest->inherit }, (@{ $use->dest->inherit }, $use->dest); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_header (\@cfg_lines); +# +# DESCRIPTION +# This method parses the header setting in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_header { + my ($self, $cfg_lines) = @_; + + # Set header lines as "parsed" + map {$_->parsed (1)} grep {$_->slabel_starts_with_cfg ('CFGFILE')} @$cfg_lines; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_inherit (\@cfg_lines); +# +# DESCRIPTION +# This method parses the inherit setting in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_inherit { + my ($self, $cfg_lines) = @_; + + # USE declaration + # ---------------------------------------------------------------------------- + my @lines = grep {$_->slabel_starts_with_cfg ('USE')} @$cfg_lines; + + # Check for cyclic dependency + if (@lines and grep {$_ eq $self->cfg->actual_src} @{ $self->inherited }) { + # Error if current configuration file is in its own inheritance hierarchy + w_report 'ERROR: ', $self->cfg->actual_src, ': attempt to inherit itself.'; + $_->error ($_->label . ': ignored due to cyclic dependency.') for (@lines); + return 0; + } + + my $rc = 1; + + for my $line (@lines) { + # Invoke new instance of the current class + my $use = ref ($self)->new; + + # Set configuration file, inheritance hierarchy + # and attempt to parse the configuration + $use->cfg->src (&expand_tilde ($line->value)); + $use->inherited ([$self->cfg->actual_src, @{ $self->inherited }]); + $use->parse_cfg; + + # Add to list of inherit configurations + push @{ $self->inherit }, $use; + + $line->parsed (1); + } + + # Check locks in inherited destination + # ---------------------------------------------------------------------------- + for my $use (@{ $self->inherit }) { + $rc = 0 unless $use->check_lock; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines (); +# +# DESCRIPTION +# This method returns the configuration lines of this object. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self) = @_; + + my @inherited_dests = map { + Fcm::CfgLine->new ( + label => $self->cfglabel ('USE'), value => $_->dest->rootdir + ); + } @{ $self->inherit }; + + return ( + Fcm::CfgLine::comment_block ('File header'), + Fcm::CfgLine->new ( + label => $self->cfglabel ('CFGFILE') . $Fcm::Config::DELIMITER . 'TYPE', + value => $self->type, + ), + Fcm::CfgLine->new ( + label => $self->cfglabel ('CFGFILE') . $Fcm::Config::DELIMITER . 'VERSION', + value => '1.0', + ), + Fcm::CfgLine->new (), + + @inherited_dests, + + Fcm::CfgLine::comment_block ('Destination'), + ($self->dest->to_cfglines()), + ); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1e/1e404e0ecccd1d2f6217aa054782a932c1e3e88c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1e/1e404e0ecccd1d2f6217aa054782a932c1e3e88c.svn-base new file mode 100644 index 0000000..e7818db --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1e/1e404e0ecccd1d2f6217aa054782a932c1e3e88c.svn-base @@ -0,0 +1,87 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive::InputGetter::CLI; +use base qw{Fcm::Interactive::InputGetter}; + +my $DEF_MSG = q{ (or just press for "%s")}; +my %EXTRA_MSG_FOR = ( + yn => qq{\nEnter "y" or "n"}, + yna => qq{\nEnter "y", "n" or "a"}, +); +my %CHECKER_FOR = ( + yn => sub {$_[0] eq 'y' || $_[0] eq 'n'}, + yna => sub {$_[0] eq 'y' || $_[0] eq 'n' || $_[0] eq 'a'}, +); + +sub invoke { + my ($self) = @_; + my $type = $self->get_type() ? lc($self->get_type()) : q{}; + my $message + = $self->get_message() + . (exists($EXTRA_MSG_FOR{$type}) ? $EXTRA_MSG_FOR{$type} : q{}) + . ($self->get_default() ? sprintf($DEF_MSG, $self->get_default()) : q{}) + . q{: } + ; + while (1) { + print($message); + my $answer = readline(STDIN); + chomp($answer); + if (!$answer && $self->get_default()) { + $answer = $self->get_default(); + } + if (!exists($CHECKER_FOR{$type}) || $CHECKER_FOR{$type}->($answer)) { + return $answer; + } + } + return; +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive::InputGetter::CLI + +=head1 SYNOPSIS + + use Fcm::Interactive; + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +This is a solid implementation of +L. It gets a user +reply from STDIN using a prompt on STDOUT. + +=head1 METHODS + +See L for a list of +methods. + +=head1 TO DO + +Use IO::Prompt. + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1f/1f16b64cb7f2356c5dc59f20c312ec1eb02a7a48.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1f/1f16b64cb7f2356c5dc59f20c312ec1eb02a7a48.svn-base new file mode 100644 index 0000000..19d6c85 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/1f/1f16b64cb7f2356c5dc59f20c312ec1eb02a7a48.svn-base @@ -0,0 +1,77 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Formatter::Entries; + +use Fcm::Keyword::Formatter::Entry; + +################################################################################ +# Constructor +sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); +} + +################################################################################ +# Formats a keyword entry +sub format { + my ($self, $entries) = @_; + my $formatter = Fcm::Keyword::Formatter::Entry->new(); + my $return = q{}; + for my $entry ( + sort {$a->get_key() cmp $b->get_key()} + grep {!$_->can('is_implied') || !$_->is_implied()} + $entries->get_all_entries() + ) { + $return .= $formatter->format($entry); + } + return $return; +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Formatter::Entries + +=head1 SYNOPSIS + + use Fcm::Keyword::Formatter::Entries; + $formatter = Fcm::Keyword::Formatter::Entries->new(); + print($formatter->format($entries)); + +=head1 DESCRIPTION + +An object of this class is used to format a keyword entries object. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item format($entries) + +Returns a simple string representation of $entries. + +=back + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/25/25e7919f36e5a5a36d716eb5f883d92d05e05e74.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/25/25e7919f36e5a5a36d716eb5f883d92d05e05e74.svn-base new file mode 100644 index 0000000..e0407ab --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/25/25e7919f36e5a5a36d716eb5f883d92d05e05e74.svn-base @@ -0,0 +1,319 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CmCommitMessage +# +# DESCRIPTION +# This class contains methods to read, write and edit the commit message file +# in a working copy. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CmCommitMessage; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw/tempfile/; + +# FCM component modules +use Fcm::Base; +use Fcm::Util qw/e_report run_command/; + +# List of property methods for this class +my @scalar_properties = ( + 'auto_mesg', # the automatically inserted part of a commit message + 'base', # the base name of the commit message file + 'dir', # the directory container of the commit message file + 'ignore_mesg', # the ignored part of a commit message + 'user_mesg', # the user defined part of a commit message +); + +# Commit log delimiter messages +my $log_delimiter = '--Add your commit message ABOVE - ' . + 'do not alter this line or those below--'; +my $auto_delimiter = '--FCM message (will be inserted automatically)--'; +my $auto_delimiter_old = '--This line will be ignored and those below ' . + 'will be inserted automatically--'; +my $status_delimiter = '--Change summary ' . + '(not part of commit message)--'; +my $status_delimiter_old = '--This line, and those below, will be ignored--'; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::CmCommitMessage->new (); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CmCommitMessage class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'base') { + # Reference to an array + $self->{$name} = '#commit_message#'; + + } elsif ($name eq 'dir') { + # Current working directory + $self->{$name} = &cwd (); + + } elsif ($name =~ /_mesg$/) { + # Reference to an array + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $file = $obj->file; +# $obj->file ($file); +# +# DESCRIPTION +# This method returns the full name of the commit message file. If an +# argument is specified, the file is reset using the value of the argument. +# ------------------------------------------------------------------------------ + +sub file { + my ($self, $file) = @_; + + if ($file) { + $self->dir (dirname ($file)); + $self->base (basename ($file)); + } + + return File::Spec->catfile ($self->dir, $self->base); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($user, $auto) = $obj->read_file (); +# +# DESCRIPTION +# This function reads from the commit log message file. It resets the user +# and the automatic messages after reading the file. It returns the message +# back in two array references. +# ------------------------------------------------------------------------------ + +sub read_file { + my $self = shift; + + my @user = (); + my @auto = (); + my $file = $self->file; + + if (-r $file) { + open FILE, '<', $file or croak 'Cannot open ', $file, '(', $!, '), abort'; + + my $in_auto = 0; + while () { + + next if (index ($_, $log_delimiter) == 0); + + if (index ($_, $status_delimiter) == 0 || + index ($_, $status_delimiter_old) == 0) { + # Ignore after the ignore delimiter + last; + } + + if (index ($_, $auto_delimiter) == 0 || + index ($_, $auto_delimiter_old) == 0) { + # Beginning of the automatically inserted message + $in_auto = 1; + next; + } + + if ($in_auto) { + push @auto, $_; + + } else { + push @user, $_; + } + } + + close FILE; + + $self->user_mesg (\@user); + $self->auto_mesg (\@auto); + } + + return (\@user, \@auto); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj->write_file (); +# +# DESCRIPTION +# This function writes to the commit log message file based on the content of +# the user defined message, and the automatically inserted message. +# ------------------------------------------------------------------------------ + +sub write_file { + my $self = shift; + my %args = @_; + + my @user = @{ $self->user_mesg }; + my @auto = @{ $self->auto_mesg }; + my $file = $self->file; + + open FILE, '>', $file or die 'Cannot open ', $file, '(', $!, '), abort'; + print FILE @user; + print FILE $log_delimiter, "\n", $auto_delimiter, "\n", @auto if @auto; + close FILE or croak 'Cannot close ', $file, '(', $!, '), abort'; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $file = $obj->edit_file ([TEMP => 1,] [BATCH => 1,]); +# +# DESCRIPTION +# This function normally triggers an editor for editing the commit message. +# If TEMP is set, it edits a temporary file. Otherwise, it edits the current +# commit message file. It resets the user defined message on success. Returns +# the name of the commit log file. Do not start the editor if BATCH is set. +# ------------------------------------------------------------------------------ + +sub edit_file { + my $self = shift; + my %args = @_; + my $temp = exists $args{TEMP} ? $args{TEMP} : 0; + my $batch = exists $args{BATCH} ? $args{BATCH} : 0; + + my @user = @{ $self->user_mesg }; + my @auto = @{ $self->auto_mesg }; + my @ignore = @{ $self->ignore_mesg }; + my $file = $self->file; + + if ($temp) { + my $fh; + ($fh, $file) = tempfile (SUFFIX => ".fcm", UNLINK => 1); + close $fh; + } + + # Add original or code driven message and status information to the file + my $select = select; + open FILE, '>', $file or croak 'Cannot open ', $file, ' (', $!, '), abort'; + select FILE; + + print @user; + print (@auto || @user ? '' : "\n"); + print $log_delimiter, "\n"; + print $auto_delimiter, "\n", @auto, "\n" if @auto; + print $status_delimiter, "\n\n"; + print @ignore if @ignore; + + close FILE or die 'Cannot close ', $file, ' (', $!, '), abort'; + select $select; + + if (not $batch) { + # Select editor + my $editor = 'nedit'; + + if ($ENV{'SVN_EDITOR'}) { + $editor = $ENV{'SVN_EDITOR'}; + + } elsif ($ENV{'VISUAL'}) { + $editor = $ENV{'VISUAL'}; + + } elsif ($ENV{'EDITOR'}) { + $editor = $ENV{'EDITOR'}; + } + + # Execute command to start the editor + print 'Starting ', $editor, ' to edit commit message ...', "\n"; + &run_command ([split (/\s+/, $editor), $file]); + } + + # Read the edited file, and extract user log message from it + open FILE, '<', $file or croak 'Cannot open ', $file, ' (', $!, '), abort'; + my (@log); + my $delimiter_found = 0; + + while () { + if (index ($_, $log_delimiter) == 0) { + $delimiter_found = 1; + last; + } + push @log, $_; + } + + close FILE; + + # Ensure log delimiter line was not altered + e_report 'Error: the line "', $log_delimiter, '" has been altered, abort.' + if not $delimiter_found; + + # Check for empty commit log + e_report 'Error: log message unchanged or not specified, abort.' + if join (' ', (@log, @auto)) =~ /^\s*$/; + + # Echo the commit message to standard output + my $separator = '-' x 80 . "\n"; + print 'Change summary:', "\n"; + print $separator, @ignore, $separator; + print 'Commit message is as follows:', "\n"; + print $separator, @log, @auto, $separator; + + open FILE, '>', $file or croak 'Cannot open ', $file, ' (', $!, '), abort'; + print FILE @log, @auto; + close FILE or croak 'Cannot close ', $file, ' (', $!, '), abort'; + + # Reset the array for the user specified log message + $self->user_mesg (\@log); + + return $file; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/29/299ed400f69fdf0f3a55a4d53a4d3d0f1a32975a.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/29/299ed400f69fdf0f3a55a4d53a4d3d0f1a32975a.svn-base new file mode 100644 index 0000000..350e3aa --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/29/299ed400f69fdf0f3a55a4d53a4d3d0f1a32975a.svn-base @@ -0,0 +1,112 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Base +# +# DESCRIPTION +# This is base class for all FCM OO packages. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Base; + +# Standard pragma +use strict; +use warnings; + +use Fcm::Config; + +my @scalar_properties = ( + 'config', # instance of Fcm::Config, configuration setting +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Base->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Base class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = {}; + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'config') { + # Configuration setting of the main program + $self->{$name} = Fcm::Config->instance(); + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $self->setting (@args); # $self->config->setting +# $value = $self->verbose (@args); # $self->config->verbose +# ------------------------------------------------------------------------------ + +for my $name (qw/setting verbose/) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + return $self->config->$name (@_); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $self->cfglabel (@args); +# +# DESCRIPTION +# This is an alias to $self->config->setting ('CFG_LABEL', @args); +# ------------------------------------------------------------------------------ + +sub cfglabel { + my $self = shift; + return $self->setting ('CFG_LABEL', @_); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/2b/2b3a057b62d84b148f16dbc298f51b591d5747c0.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/2b/2b3a057b62d84b148f16dbc298f51b591d5747c0.svn-base new file mode 100644 index 0000000..1644080 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/2b/2b3a057b62d84b148f16dbc298f51b591d5747c0.svn-base @@ -0,0 +1,1346 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Cwd; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Timer; +use Fcm::Util; +use File::Basename; +use File::Spec; +use Tk; +use Tk::ROText; + +# ------------------------------------------------------------------------------ + +# Argument +if (@ARGV) { + my $dir = shift @ARGV; + chdir $dir if -d $dir; +} + +# Get configuration settings +my $config = Fcm::Config->new (); +$config->get_config (); + +# ------------------------------------------------------------------------------ + +# FCM subcommands +my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT + UPDATE SWITCH/; + +# Subcommands allowed when CWD is not a WC +my @nwc_subcmds = qw/CHECKOUT BRANCH/; + +# Subcommands allowed, when CWD is a WC +my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE + SWITCH/; + +# Subcommands that apply to WC only +my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE + SWITCH/; + +# Subcommands that apply to top level WC only +my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/; + +# Selected subcommand +my $selsubcmd = ''; + +# Selected subcommand is running? +my $cmdrunning = 0; + +# PID of running subcommand +my $cmdpid = undef; + +# List of subcommand frames +my %subcmd_f; + +# List of subcommand buttons +my %subcmd_b; + +# List of subcommand button help strings +my %subcmd_help = ( + BRANCH => 'list information about, create or delete a branch.', + CHECKOUT => 'check out a working copy from a repository.', + STATUS => 'print the status of working copy files and directories.', + DIFF => 'display the differences in modified files.', + ADD => 'put files and directories under version control.', + DELETE => 'remove files and directories from version control.', + MERGE => 'merge changes into your working copy.', + CONFLICTS => 'use a graphical tool to resolve conflicts in your working copy.', + COMMIT => 'send changes from your working copy to the repository.', + UPDATE => 'bring changes from the repository into your working copy.', + SWITCH => 'update your working copy to a different URL.', +); + +for (keys %subcmd_help) { + $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' . + $subcmd_help{$_}; +} + +# List of subcommand button bindings (key name and underline position) +my %subcmd_bind = ( + BRANCH => {KEY => '', U => 0}, + CHECKOUT => {KEY => '', U => 5}, + STATUS => {KEY => '', U => 0}, + DIFF => {KEY => '', U => 0}, + ADD => {KEY => '', U => 0}, + DELETE => {KEY => '', U => 4}, + MERGE => {KEY => '', U => 0}, + CONFLICTS => {KEY => '', U => 3}, + COMMIT => {KEY => '', U => 0}, + UPDATE => {KEY => '', U => 0}, + SWITCH => {KEY => '', U => 1}, +); + +# List of subcommand variables +my %subcmdvar = ( + CWD => cwd (), + WCT => '', + CWD_URL => '', + WCT_URL => '', + + BRANCH => { + OPT => 'info', + URL => '', + NAME => '', + TYPE => 'DEV', + REVFLAG => 'NORMAL', + REV => '', + TICKET => '', + SRCTYPE => 'trunk', + S_CHD => 0, + S_SIB => 0, + S_OTH => 0, + VERBOSE => 0, + OTHER => '', + }, + + CHECKOUT => { + URL => '', + REV => 'HEAD', + PATH => '', + OTHER => '', + }, + + STATUS => { + USEWCT => 0, + UPDATE => 0, + VERBOSE => 0, + OTHER => '', + }, + + DIFF => { + USEWCT => 0, + TOOL => 'graphical', + BRANCH => 0, + URL => '', + OTHER => '', + }, + + ADD => { + USEWCT => 0, + CHECK => 1, + OTHER => '', + }, + + DELETE => { + USEWCT => 0, + CHECK => 1, + OTHER => '', + }, + + MERGE => { + USEWCT => 1, + SRC => '', + MODE => 'automatic', + DRYRUN => 0, + VERBOSE => 0, + REV => '', + OTHER => '', + }, + + CONFLICTS => { + USEWCT => 0, + OTHER => '', + }, + + COMMIT => { + USEWCT => 1, + DRYRUN => 0, + OTHER => '', + }, + + UPDATE => { + USEWCT => 1, + OTHER => '', + }, + + SWITCH => { + USEWCT => 1, + URL => '', + OTHER => '', + }, +); + +# List of action buttons +my %action_b; + +# List of action button help strings +my %action_help = ( + QUIT => 'Quit fcm gui', + HELP => 'Print help to the output text box for the selected sub-command', + CLEAR => 'Clear the output text box', + RUN => 'Run the selected sub-command', +); + +# List of action button bindings +my %action_bind = ( + QUIT => {KEY => '', U => undef}, + HELP => {KEY => '' , U => undef}, + CLEAR => {KEY => '' , U => 1}, + RUN => {KEY => '' , U => 0}, +); + +# List of branch subcommand options +my %branch_opt = ( + INFO => undef, + CREATE => undef, + DELETE => undef, + LIST => undef, +); + +# List of branch create types +my %branch_type = ( + 'DEV' => undef, + 'DEV::SHARE' => undef, + 'TEST' => undef, + 'TEST::SHARE' => undef, + 'PKG' => undef, + 'PKG::SHARE' => undef, + 'PKG::CONFIG' => undef, + 'PKG::REL' => undef, +); + +# List of branch create source type +my %branch_srctype = ( + TRUNK => undef, + BRANCH => undef, +); + +# List of branch create revision prefix option +my %branch_revflag = ( + NORMAL => undef, + NUMBER => undef, + NONE => undef, +); + +# List of branch info/delete options +my %branch_info_opt = ( + S_CHD => 'Show children', + S_SIB => 'Show siblings', + S_OTH => 'Show other', + VERBOSE => 'Print extra information', +); + +# List of diff display options +my %diff_display_opt = ( + default => 'Default mode', + graphical => 'Graphical tool', + trac => 'Trac (only for diff relative to the base of the branch)', +); + +# Text in the status bar +my $statustext = ''; + +# ------------------------------------------------------------------------------ + +my $mw = MainWindow->new (); + +my $mw_title = 'FCM GUI'; +$mw->title ($mw_title); + +# Frame containing subcommand selection buttons +my $top_f = $mw->Frame ()->grid ( + '-row' => 0, + '-column' => 0, + '-sticky' => 'w', +); + +# Frame containing subcommand options +my $mid_f = $mw->Frame ()->grid ( + '-row' => 1, + '-column' => 0, + '-sticky' => 'ew', +); + +# Frame containing action buttons +my $bot_f = $mw->Frame ()->grid ( + '-row' => 2, + '-column' => 0, + '-sticky' => 'ew', +); + +# Text box to display output +my $out_t = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid ( + '-row' => 3, + '-column' => 0, + '-sticky' => 'news', +); + +# Text box - allow scroll with mouse wheel +$out_t->bind ( + '<4>' => sub { + $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif; + }, +); + +$out_t->bind ( + '<5>' => sub { + $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif; + }, +); + +# Status bar +$mw->Label ( + '-textvariable' => \$statustext, + '-relief' => 'groove', +)->grid ( + '-row' => 4, + '-column' => 0, + '-sticky' => 'ews', +); + +# Main window grid configure +{ + my ($cols, $rows) = $mw->gridSize (); + $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1); + $mw->gridRowconfigure ( 3, '-weight' => 1); +} + +# Frame grid configure +{ + my ($cols, $rows) = $mid_f->gridSize (); + $bot_f->gridColumnconfigure (3, '-weight' => 1); +} + +$mid_f->gridRowconfigure (0, '-weight' => 1); +$mid_f->gridColumnconfigure (0, '-weight' => 1); + +# ------------------------------------------------------------------------------ + +# Buttons to select subcommands +{ + my $col = 0; + for my $name (@subcmds) { + $subcmd_b{$name} = $top_f->Button ( + '-text' => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)), + '-command' => [\&button_clicked, $name], + '-width' => 8, + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + + $subcmd_b{$name}->bind ('', sub {$statustext = $subcmd_help{$name}}); + $subcmd_b{$name}->bind ('', sub {$statustext = ''}); + + $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U}) + if defined $subcmd_bind{$name}{U}; + + $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke}); + } +} + +# ------------------------------------------------------------------------------ + +# Frames to contain subcommands options +{ + my %row = (); + + for my $name (@subcmds) { + $subcmd_f{$name} = $mid_f->Frame (); + $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1); + + $row{$name} = 0; + + # Widgets common to all sub-commands + $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + } + + # Widgets common to all sub-commands that apply to working copies + for my $name (@wco_subcmds) { + my @labtxts = ( + 'Corresponding URL: ', + 'Working copy top: ', + 'Corresponding URL: ', + ); + my @varrefs = \( + $subcmdvar{URL_CWD}, + $subcmdvar{WCT}, + $subcmdvar{URL_WCT}, + ); + + for my $i (0 .. $#varrefs) { + $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + } + + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Apply sub-command to working copy top', + '-variable' => \($subcmdvar{$name}{USEWCT}), + '-state' => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + + # Widget for the Branch sub-command + { + my $name = 'BRANCH'; + + # Radio buttons to select the sub-option of the branch sub-command + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_opt) { + my $opt = lc $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $opt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{OPT}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + + # Label and entry box for specifying URL + $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{URL}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and entry box for specifying create branch name + $subcmd_f{$name}->Label ( + '-text' => 'Branch name (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{NAME}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and entry box for specifying create branch source revision + $subcmd_f{$name}->Label ( + '-text' => 'Source revision (create/list only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{REV}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and radio buttons box for specifying create branch type + $subcmd_f{$name}->Label ( + '-text' => 'Branch type (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_type) { + my $txt = lc $key; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{TYPE}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Label and radio buttons box for specifying create source type + $subcmd_f{$name}->Label ( + '-text' => 'Source type (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_srctype) { + my $txt = lc $key; + my $opt = lc $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{SRCTYPE}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Label and radio buttons box for specifying create prefix option + $subcmd_f{$name}->Label ( + '-text' => 'Prefix option (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_revflag) { + my $txt = lc $key; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{REVFLAG}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Label and entry box for specifying ticket number + $subcmd_f{$name}->Label ( + '-text' => 'Related Trac ticket(s) (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{TICKET}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Check button for info/delete + # --show-children, --show-siblings, --show-other, --verbose + $subcmd_f{$name}->Label ( + '-text' => 'Options for info/delete only: ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + + for my $key (sort keys %branch_info_opt) { + $opt_f->Checkbutton ( + '-text' => $branch_info_opt{$key}, + '-variable' => \($subcmdvar{$name}{$key}), + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + } + + # Widget for the Checkout sub-command + { + my $name = 'CHECKOUT'; + + # Label and entry boxes for specifying URL and revision + my @labtxts = ( + 'URL: ', + 'Revision: ', + 'Path: ', + ); + my @varrefs = \( + $subcmdvar{$name}{URL}, + $subcmdvar{$name}{REV}, + $subcmdvar{$name}{PATH}, + ); + + for my $i (0 .. $#varrefs) { + $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => $varrefs[$i], + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + } + + # Widget for the Status sub-command + { + my $name = 'STATUS'; + + # Checkbuttons for various options + my @labtxts = ( + 'Display update information', + 'Print extra information', + ); + my @varrefs = \( + $subcmdvar{$name}{UPDATE}, + $subcmdvar{$name}{VERBOSE}, + ); + + for my $i (0 .. $#varrefs) { + $subcmd_f{$name}->Checkbutton ( + '-text' => $labtxts[$i], + '-variable' => $varrefs[$i], + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + } + + # Widget for the Diff sub-command + { + my $name = 'DIFF'; + + my $entry; + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Show differences relative to the base of the branch', + '-variable' => \($subcmdvar{$name}{BRANCH}), + '-command' => sub { + $entry->configure ( + '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'), + ); + }, + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + # Label and radio buttons box for specifying tool + $subcmd_f{$name}->Label ( + '-text' => 'Display diff in: ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (qw/default graphical trac/) { + my $txt = $diff_display_opt{$key}; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{TOOL}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + $entry = $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{URL}), + '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + + # Widget for the Add/Delete sub-command + for my $name (qw/ADD DELETE/) { + + # Checkbuttons for various options + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Check for files or directories not under version control', + '-variable' => \($subcmdvar{$name}{CHECK}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + + # Widget for the Merge sub-command + { + my $name = 'MERGE'; + + # Label and radio buttons box for specifying merge mode + $subcmd_f{$name}->Label ( + '-text' => 'Mode: ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (qw/automatic custom reverse/) { + my $txt = lc $key; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{MODE}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Check buttons for dry-run + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Dry run', + '-variable' => \($subcmdvar{$name}{DRYRUN}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + # Check buttons for verbose mode + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Print extra information', + '-variable' => \($subcmdvar{$name}{VERBOSE}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + # Label and entry boxes for specifying merge source + $subcmd_f{$name}->Label ( + '-text' => 'Source (automatic/custom only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{SRC}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and entry boxes for specifying merge revision (range) + $subcmd_f{$name}->Label ( + '-text' => 'Revision (custom/reverse only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{REV}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + + # Widget for the Commit sub-command + { + my $name = 'COMMIT'; + + # Checkbuttons for various options + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Dry run', + '-variable' => \($subcmdvar{$name}{DRYRUN}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + + # Widget for the Switch sub-command + { + my $name = 'SWITCH'; + + # Label and entry boxes for specifying switch URL + $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{URL}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + + # Widgets common to all sub-commands + for my $name (@subcmds) { + $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{OTHER}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } +} + +# ------------------------------------------------------------------------------ + +# Buttons to perform main actions +{ + my $col = 0; + for my $name (qw/QUIT HELP CLEAR RUN/) { + $action_b{$name} = $bot_f->Button ( + '-text' => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)), + '-command' => [\&button_clicked, $name], + '-width' => 8, + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'), + ); + + $action_b{$name}->bind ('', sub {$statustext = $action_help{$name}}); + $action_b{$name}->bind ('', sub {$statustext = ''}); + + $action_b{$name}->configure ('-underline' => $action_bind{$name}{U}) + if defined $action_bind{$name}{U}; + + $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke}); + } +} + +&change_cwd ($subcmdvar{CWD}); + +# ------------------------------------------------------------------------------ + +# Handle the situation when the user attempts to quit the window while a +# sub-command is running + +$mw->protocol ('WM_DELETE_WINDOW', sub { + if (defined $cmdpid) { + my $ans = $mw->messageBox ( + '-title' => $mw_title, + '-message' => $selsubcmd . ' is still running. Really quit?', + '-type' => 'YesNo', + '-default' => 'No', + ); + + if ($ans eq 'Yes') { + kill 9, $cmdpid; # Need to kill the sub-process before quitting + + } else { + return; # Do not quit + } + } + + exit; +}); + +MainLoop; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &change_cwd ($dir); +# +# DESCRIPTION +# Change current working directory to $dir +# ------------------------------------------------------------------------------ + +sub change_cwd { + my $dir = $_[0]; + my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds); + + for my $subcmd (@subcmds) { + if (grep {$_ eq $subcmd} @allowed_subcmds) { + $subcmd_b{$subcmd}->configure ('-state' => 'normal'); + + } else { + $subcmd_b{$subcmd}->configure ('-state' => 'disabled'); + } + } + + &display_subcmd_frame ($allowed_subcmds[0]) + if not grep {$_ eq $selsubcmd} @allowed_subcmds; + + chdir $dir; + $subcmdvar{CWD} = $dir; + + if (&is_wc ($dir)) { + $subcmdvar{WCT} = &get_wct ($dir); + $subcmdvar{URL_CWD} = &get_url_of_wc ($dir); + $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}); + + $branch_opt{INFO} ->configure ('-state' => 'normal'); + $branch_opt{DELETE}->configure ('-state' => 'normal'); + $subcmdvar{BRANCH}{OPT} = 'info'; + + } else { + $branch_opt{INFO} ->configure ('-state' => 'disabled'); + $branch_opt{DELETE}->configure ('-state' => 'disabled'); + $subcmdvar{BRANCH}{OPT} = 'create'; + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &button_clicked ($name); +# +# DESCRIPTION +# Call back function to handle a click on a command button named $name. +# ------------------------------------------------------------------------------ + +sub button_clicked { + my $name = $_[0]; + + if (grep {$_ eq $name} keys %subcmd_b) { + &display_subcmd_frame ($name); + + } elsif ($name eq 'CLEAR') { + $out_t->delete ('1.0', 'end'); + + } elsif ($name eq 'QUIT') { + exit; + + } elsif ($name eq 'HELP') { + &invoke_cmd ('help ' . lc ($selsubcmd)); + + } elsif ($name eq 'RUN') { + &invoke_cmd (&setup_cmd ($selsubcmd)); + + } else { + $out_t->insert ('end', $name . ': function to be implemented' . "\n"); + $out_t->yviewMoveto (1); + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &display_subcmd_frame ($name); +# +# DESCRIPTION +# Change selected subcommand to $name, and display the frame containing the +# widgets for configuring the options and arguments of that subcommand. +# ------------------------------------------------------------------------------ + +sub display_subcmd_frame { + my $name = $_[0]; + + if ($selsubcmd ne $name and not $cmdrunning) { + $subcmd_b{$name }->configure ('-relief' => 'sunken'); + $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd; + + $subcmd_f{$name }->grid ('-sticky' => 'new'); + $subcmd_f{$selsubcmd}->gridForget if $selsubcmd; + + $selsubcmd = $name; + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $pos = &get_wm_pos (); +# +# DESCRIPTION +# Returns the position part of the geometry string of the main window. +# ------------------------------------------------------------------------------ + +sub get_wm_pos { + my $geometry = $mw->geometry (); + $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/; + return $1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $command = &setup_cmd ($name); +# +# DESCRIPTION +# Setup the the system command for the sub-command $name. +# ------------------------------------------------------------------------------ + +sub setup_cmd { + my $name = $_[0]; + my $cmd = ''; + + if ($name eq 'BRANCH') { + $cmd .= lc ($name); + if ($subcmdvar{$name}{OPT} eq 'create') { + $cmd .= ' -c --svn-non-interactive'; + $cmd .= ' -n ' . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME}; + $cmd .= ' -t ' . $subcmdvar{$name}{TYPE}; + $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG}; + $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET}; + $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch'; + + } elsif ($subcmdvar{$name}{OPT} eq 'delete') { + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + $cmd .= ' -d --svn-non-interactive'; + + } elsif ($subcmdvar{$name}{OPT} eq 'list') { + $cmd .= ' -l'; + $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + + } else { + $cmd .= ' -i'; + $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD}; + $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB}; + $cmd .= ' --show-other' if $subcmdvar{$name}{S_OTH}; + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + } + $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'CHECKOUT') { + $cmd .= lc ($name); + $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + $cmd .= ' ' . $subcmdvar{$name}{URL}; + $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH}; + + } elsif ($name eq 'STATUS') { + $cmd .= lc ($name); + $cmd .= ' -u' if $subcmdvar{$name}{UPDATE}; + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'DIFF') { + $cmd .= lc ($name); + $cmd .= ' -g' if $subcmdvar{$name}{TOOL} eq 'graphical'; + + if ($subcmdvar{$name}{BRANCH}) { + $cmd .= ' -b'; + $cmd .= ' -t' if $subcmdvar{$name}{TOOL} eq 'trac'; + $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL}; + } + + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'ADD' or $name eq 'DELETE') { + $cmd .= lc ($name); + $cmd .= ' -c' if $subcmdvar{$name}{CHECK}; + $cmd .= ' --non-interactive' + if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'MERGE') { + $cmd .= lc ($name); + + if ($subcmdvar{$name}{MODE} ne 'automatic') { + $cmd .= ' --' . $subcmdvar{$name}{MODE}; + $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + } + + $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN}; + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + $cmd .= ' ' . $subcmdvar{$name}{SRC} if $subcmdvar{$name}{SRC}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'CONFLICTS') { + $cmd .= lc ($name); + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'COMMIT') { + $cmd .= lc ($name); + $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN}; + $cmd .= ' --svn-non-interactive'; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'SWITCH') { + $cmd .= lc ($name); + $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'UPDATE') { + $cmd .= lc ($name); + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } + + return $cmd; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &invoke_cmd ($cmd); +# +# DESCRIPTION +# Invoke the command $cmd. +# ------------------------------------------------------------------------------ + +sub invoke_cmd { + my $cmd = $_[0]; + return unless $cmd; + + my $disp_cmd = 'fcm ' . $cmd; + $cmd = (index ($cmd, 'help ') == 0) + ? $disp_cmd + : ('fcm gui-internal ' . &get_wm_pos () . ' ' . $cmd); + + # Change directory to working copy top if necessary + if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) { + chdir $subcmdvar{WCT}; + $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n"); + $out_t->yviewMoveto (1); + } + + # Report start of command + $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start')); + $out_t->yviewMoveto (1); + + # Open the command as a pipe + if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') { + # Disable all action buttons + $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b); + $cmdrunning = 1; + + # Set up a file event to read output from the command + $mw->fileevent (\*CMD, readable => sub { + if (sysread CMD, my ($buf), 1024) { + # Insert text into the output text box as it becomes available + $out_t->insert ('end', $buf); + $out_t->yviewMoveto (1); + + } else { + # Delete the file event and close the file when the command finishes + $mw->fileevent(\*CMD, readable => ''); + close CMD; + $cmdpid = undef; + + # Check return status + if ($?) { + $out_t->insert ( + 'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n", + ); + $out_t->yviewMoveto (1); + } + + # Report end of command + $out_t->insert ('end', timestamp_command ($disp_cmd, 'End')); + $out_t->yviewMoveto (1); + + # Change back to CWD if necessary + if ($subcmdvar{$selsubcmd}{USEWCT} and + $subcmdvar{WCT} ne $subcmdvar{CWD}) { + chdir $subcmdvar{CWD}; + $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n"); + $out_t->yviewMoveto (1); + } + + # Enable all action buttons again + $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b); + $cmdrunning = 0; + + # If the command is "checkout", change directory to working copy + if (lc ($selsubcmd) eq 'checkout' && $subcmdvar{CHECKOUT}{URL}) { + my $url = Fcm::Keyword::expand($subcmdvar{CHECKOUT}{URL}); + my $dir = $subcmdvar{CHECKOUT}{PATH} + ? $subcmdvar{CHECKOUT}{PATH} + : basename $url; + $dir = File::Spec->rel2abs ($dir); + &change_cwd ($dir); + + # If the command is "switch", change URL + } elsif (lc ($selsubcmd) eq 'switch') { + $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1); + $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1); + } + } + 1; + }); + + } else { + $mw->messageBox ( + '-title' => 'Error', + '-message' => 'Error running "' . $cmd . '"', + '-icon' => 'error', + ); + } + + return; +} + +# ------------------------------------------------------------------------------ + +__END__ + +=head1 NAME + +fcm_gui + +=head1 SYNOPSIS + +fcm_gui [DIR] + +=head1 DESCRIPTION + +The fcm_gui command is a simple graphical user interface for some of the +commands of the FCM system. The optional argument DIR modifies the initial +working directory. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/2f/2f508e05aafbbf1bce26eb86a6946faacfc6885e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/2f/2f508e05aafbbf1bce26eb86a6946faacfc6885e.svn-base new file mode 100644 index 0000000..bc09fe7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/2f/2f508e05aafbbf1bce26eb86a6946faacfc6885e.svn-base @@ -0,0 +1,264 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::SrcDirLayer +# +# DESCRIPTION +# This class contains methods to manipulate the extract of a source +# directory from a branch of a (Subversion) repository. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use warnings; +use strict; + +package Fcm::SrcDirLayer; +use base qw{Fcm::Base}; + +use Fcm::Util qw{run_command e_report w_report}; +use File::Basename qw{dirname}; +use File::Path qw{mkpath}; +use File::Spec; + +# List of property methods for this class +my @scalar_properties = ( + 'cachedir', # cache directory for this directory branch + 'commit', # revision at which the source directory was changed + 'extracted', # is this branch already extracted? + 'files', # list of source files in this directory branch + 'location', # location of the source directory in the branch + 'name', # sub-package name of the source directory + 'package', # top level package name of which the current repository belongs + 'reposroot', # repository root URL + 'revision', # revision of the repository branch + 'tag', # package/revision tag of the current repository branch + 'type', # type of the repository branch ("svn" or "user") +); + +my %ERR_MESS_OF = ( + CACHE_WRITE => '%s: cannot write to cache', + SYMLINK => '%s/%s: ignore symbolic link', + VC_TYPE => '%s: repository type not supported', +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::SrcDirLayer->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::SrcDirLayer class. See +# above for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'files') { + # Reference to an array + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# Handles error/warning events. +sub _err { + my ($key, $args_ref, $warn_only) = @_; + my $reporter = $warn_only ? \&w_report : \&e_report; + $args_ref ||= []; + $reporter->(sprintf($ERR_MESS_OF{$key} . ".\n", @{$args_ref})); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $dir = $obj->localdir; +# +# DESCRIPTION +# This method returns the user or cache directory for the current revision +# of the repository branch. +# ------------------------------------------------------------------------------ + +sub localdir { + my $self = shift; + + return $self->user ? $self->location : $self->cachedir; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $user = $obj->user; +# +# DESCRIPTION +# This method returns the string "user" if the current source directory +# branch is a local directory. Otherwise, it returns "undef". +# ------------------------------------------------------------------------------ + +sub user { + my $self = shift; + + return $self->type eq 'user' ? 'user' : undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $obj->get_commit; +# +# DESCRIPTION +# If the current repository type is "svn", this method attempts to obtain +# the revision in which the branch is last committed. On a successful +# operation, it returns this revision number. Otherwise, it returns +# "undef". +# ------------------------------------------------------------------------------ + +sub get_commit { + my $self = shift; + + if ($self->type eq 'svn') { + # Execute the "svn info" command + my @lines = &run_command ( + [qw/svn info -r/, $self->revision, $self->location . '@' . $self->revision], + METHOD => 'qx', TIME => $self->config->verbose > 2, + ); + + my $rev; + for (@lines) { + if (/^Last\s+Changed\s+Rev\s*:\s*(\d+)/i) { + $rev = $1; + last; + } + } + + # Commit revision of this source directory + $self->commit ($rev); + + return $self->commit; + + } elsif ($self->type eq 'user') { + return; + + } else { + _err('VC_TYPE', [$self->type()]); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->update_cache; +# +# DESCRIPTION +# If the current repository type is "svn", this method attempts to extract +# the current revision source directory from the current branch from the +# repository, sending the output to the cache directory. It returns true on +# a successful operation, or false if the repository is not of type "svn". +# ------------------------------------------------------------------------------ + +sub update_cache { + my $self = shift; + + return unless $self->cachedir; + + # Create cache extract destination, if necessary + my $dirname = dirname $self->cachedir; + mkpath($dirname); + + if (!-w $dirname) { + _err('CACHE_WRITE', [$dirname]); + } + + if ($self->type eq 'svn') { + # Set up the extract command, "svn export --force -q -N" + my @command = ( + qw/svn export --force -q -N/, + $self->location . '@' . $self->revision, + $self->cachedir, + ); + + &run_command (\@command, TIME => $self->config->verbose > 2); + + } elsif ($self->type eq 'user') { + return; + + } else { + _err('VC_TYPE', [$self->type()]); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @files = $obj->get_files(); +# +# DESCRIPTION +# This method returns a list of file base names in the (cache of) this source +# directory in the current branch. +# ------------------------------------------------------------------------------ + +sub get_files { + my ($self) = @_; + opendir(my $dir, $self->localdir()) + || die($self->localdir(), ': cannot read directory'); + my @base_names = (); + BASE_NAME: + while (my $base_name = readdir($dir)) { + if ($base_name =~ qr{\A\.}xms || $base_name =~ qr{~\z}xms) { + next BASE_NAME; + } + my $path = File::Spec->catfile($self->localdir(), $base_name); + if (-d $path) { + next BASE_NAME; + } + if (-l $path) { + _err('SYMLINK', [$self->location(), $base_name], 1); + next BASE_NAME; + } + push(@base_names, $base_name); + } + closedir($dir); + $self->files(\@base_names); + return @base_names; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/32/3227efee21987f18ef2581e8b5cbf16fd8dacc0b.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/32/3227efee21987f18ef2581e8b5cbf16fd8dacc0b.svn-base new file mode 100644 index 0000000..ee3c0ba --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/32/3227efee21987f18ef2581e8b5cbf16fd8dacc0b.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::ExtractConfigComparator'; + use_ok($class); +} + +# TODO: more real tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/33/33a5d9d6ad684f56151894e2c140e7ed07f2a950.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/33/33a5d9d6ad684f56151894e2c140e7ed07f2a950.svn-base new file mode 100644 index 0000000..24ca25d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/33/33a5d9d6ad684f56151894e2c140e7ed07f2a950.svn-base @@ -0,0 +1,119 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::Browser; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Util qw{expand_tilde get_url_of_wc is_wc run_command}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my $config = Fcm::Config->instance(); + my $browser + = $self->get_options()->{browser} ? $self->get_options()->{browser} + : $config->setting(qw/WEB_BROWSER/) + ; + my ($target) = $self->get_arguments(); + if (!$target) { + if (is_wc()) { + $target = q{.}; + } + else { + croak(Fcm::CLI::Exception->new({ + message => 'no TARGET specified and . not a working copy', + })); + } + } + $target = expand_tilde($target); + if (-e $target) { + $target = get_url_of_wc($target); + } + + my $browser_url = Fcm::Keyword::get_browser_url($target); + my @command = (split(qr{\s+}xms, $browser), $browser_url); + run_command(\@command, METHOD => 'exec', PRINT => 1); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::Browser + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::Browser; + $invoker = Fcm::CLI::Invoker::Browser->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke a web browser of a VC +location. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes a web browser for a VC target, if it can be mapped to a browser URL. If +a target is not specified in arguments, it uses the current working directory +as the target. + +If the browser option is set, it is used as the browser command. Otherwise, the +default browser is used. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if no target is specified +and a target cannot be deduced from the current working directory. + +=item L + +The invoke() method can croak() with this exception if the target cannot be +mapped to a browser URL. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/34/34c516eb38e89a73e22ec712e160003b68d6e7e7.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/34/34c516eb38e89a73e22ec712e160003b68d6e7e7.svn-base new file mode 100644 index 0000000..bbdf321 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/34/34c516eb38e89a73e22ec712e160003b68d6e7e7.svn-base @@ -0,0 +1,43 @@ +=head1 NAME + +Fcm::Keyword::Loader + +=head1 SYNOPSIS + + $loader->load_to($entries); + +=head1 DESCRIPTION + +This is an interface of a class that loads FCM keywords into a +L object. + +=head1 METHODS + +=over 4 + +=item get_source() + +The name of the source where this loader loads its FCM keywords from. + +=item load_to($entries) + +Loads FCM keywords into $entries, which should be a +L object. Returns the number of +successfully loaded entries. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/37/37e02ae66bbbbebadba6e03f50ff057b544d4bdd.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/37/37e02ae66bbbbebadba6e03f50ff057b544d4bdd.svn-base new file mode 100644 index 0000000..23d018c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/37/37e02ae66bbbbebadba6e03f50ff057b544d4bdd.svn-base @@ -0,0 +1,143 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Config; + +use Carp; +use Fcm::Keyword::Entries; +use Fcm::Keyword::Exception; +use Fcm::Util::ClassLoader; + +our %CONFIG_OF = ( + LOCATION_ENTRIES => { + entry_class => 'Fcm::Keyword::Entry::Location', + loaders => [ + { + class => 'Fcm::Keyword::Loader::Config::Location', + }, + ], + }, + REVISION_ENTRIES => { + entry_class => 'Fcm::Keyword::Entry', + loaders => [ + { + class => 'Fcm::Keyword::Loader::Config::Revision', + options => [{key => 'namespace', valuekey => 'key'}], + }, + { + class => 'Fcm::Keyword::Loader::VC::Revision', + options => [{key => 'source', valuekey => 'value'}], + }, + ], + }, +); + +################################################################################ +# Returns a Fcm::Keyword::Entries object for given configuration +sub get_entries { + my ($context, $args_ref) = @_; + if (!exists($CONFIG_OF{$context})) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: keyword configuration not found", $context, + )})); + } + my $config_ref = $CONFIG_OF{$context}; + my @loaders; + if (exists($config_ref->{loaders})) { + for my $loader_config (@{$config_ref->{loaders}}) { + my $class = $loader_config->{class}; + Fcm::Util::ClassLoader::load($class); + my %options; + if (exists($loader_config->{options})) { + for my $option_ref (@{$loader_config->{options}}) { + my $key = $option_ref->{key}; + my $value; + if (exists($option_ref->{value})) { + $value = $option_ref->{value}; + } + elsif ( + exists($option_ref->{valuekey}) + && $args_ref + && ref($args_ref) eq 'HASH' + && exists($args_ref->{$option_ref->{valuekey}}) + ) { + $value = $args_ref->{$option_ref->{valuekey}}; + } + $options{$key} = $value; + } + } + push @loaders, $class->new(\%options); + } + } + my %entries_options = ( + (@loaders ? (loaders => \@loaders) : ()), + ( + exists($config_ref->{entry_class}) + ? (entry_class => $config_ref->{entry_class}) + : () + ), + ); + return Fcm::Keyword::Entries->new(\%entries_options); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Config + +=head1 SYNOPSIS + + use Fcm::Keyword::Config; + +=head1 DESCRIPTION + +This module stores the default configuration used by modules in the +L family. + +=head1 FUNCTIONS + +=over 4 + +=item get_entries($context,$args_ref) + +Returns a L object for a given +$context. If there is no matching $context in the configuration, croak() with a +L. $args_ref is an optional +argument, which should be a reference to a hash containing a I and a +I element. It can be used by this function to set up the constructor +options in the loaders of the returned +L object. + +=back + +=head1 DIAGNOSTICS + +=head1 TO DO + +Allow configuration to be changed in runtime. + +Convert this module to OO? + +Separate configuration from logic if this module becomes any bigger. + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/3c/3c1dcc7e710337c56e28acd558f29cbb40f896b2.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/3c/3c1dcc7e710337c56e28acd558f29cbb40f896b2.svn-base new file mode 100644 index 0000000..8e6131c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/3c/3c1dcc7e710337c56e28acd558f29cbb40f896b2.svn-base @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Exception'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $e = $class->new({message => 'message'}); + isa_ok($e, $class, $prefix); + is("$e", "$class: message\n", "$prefix: as_string()"); + is($e->get_message(), 'message', "$prefix: get_message()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/3c/3c596c89752d2633a1237edcdb40dfbec23bff25.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/3c/3c596c89752d2633a1237edcdb40dfbec23bff25.svn-base new file mode 100644 index 0000000..5439074 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/3c/3c596c89752d2633a1237edcdb40dfbec23bff25.svn-base @@ -0,0 +1,80 @@ +SVN-fs-dump-format-version: 2 + +UUID: 1a576f26-974a-0410-964b-c09797d35b3b + +Revision-number: 0 +Prop-content-length: 56 +Content-length: 56 + +K 8 +svn:date +V 27 +2008-04-11T11:22:32.220157Z +PROPS-END + +Revision-number: 1 +Prop-content-length: 109 +Content-length: 109 + +K 7 +svn:log +V 10 +For test. + +K 10 +svn:author +V 4 +frsn +K 8 +svn:date +V 27 +2008-04-11T11:31:10.571895Z +PROPS-END + +Node-path: bar +Node-kind: dir +Node-action: add +Prop-content-length: 73 +Content-length: 73 + +K 12 +fcm:revision +V 39 +bar3 = 3 +bar3.1 = 31 +bar3.14 = 314 + +PROPS-END + + +Node-path: baz +Node-kind: dir +Node-action: add +Prop-content-length: 75 +Content-length: 75 + +K 12 +fcm:revision +V 41 +bear = 4 + + + +bee = 6 + +spider = 8 + +mistake + +PROPS-END + + +Node-path: foo +Node-kind: dir +Node-action: add +Prop-content-length: 10 +Content-length: 10 + +PROPS-END + + diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/40/4065a2a990b97e8378e43c17c69bf69b3885fdae.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/40/4065a2a990b97e8378e43c17c69bf69b3885fdae.svn-base new file mode 100644 index 0000000..a514e55 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/40/4065a2a990b97e8378e43c17c69bf69b3885fdae.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::CM'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/420ceef1f099f7aef6d298a03a7ccb018ca95108.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/420ceef1f099f7aef6d298a03a7ccb018ca95108.svn-base new file mode 100644 index 0000000..c65afd2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/420ceef1f099f7aef6d298a03a7ccb018ca95108.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::KeywordPrinter'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/42c1956b6f8a6e052351b93e9be3f9e7ec5056bb.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/42c1956b6f8a6e052351b93e9be3f9e7ec5056bb.svn-base new file mode 100644 index 0000000..da3e1e0 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/42c1956b6f8a6e052351b93e9be3f9e7ec5056bb.svn-base @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $module = 'Fcm::Keyword::Config'; + use_ok($module); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/42dc5b136f2a5458cfca6368edb268bf3ed90fa2.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/42dc5b136f2a5458cfca6368edb268bf3ed90fa2.svn-base new file mode 100644 index 0000000..55edafc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/42/42dc5b136f2a5458cfca6368edb268bf3ed90fa2.svn-base @@ -0,0 +1,64 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Formatter::Entry; + +################################################################################ +# Constructor +sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); +} + +################################################################################ +# Formats a keyword entry +sub format { + my ($self, $entry) = @_; + return sprintf("%s = %s\n", $entry->get_key(), $entry->get_value()); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Formatter::Entry + +=head1 SYNOPSIS + + use Fcm::Keyword::Formatter::Entry; + $formatter = Fcm::Keyword::Formatter::Entry->new(); + print($formatter->format($entry)); + +=head1 DESCRIPTION + +An object of this class is used to format a keyword entry. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item format($entry) + +Returns a simple string representation of $entry. + +=back + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/46/46e4ad74482a96c8b6c375d849e7755edc47bd21.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/46/46e4ad74482a96c8b6c375d849e7755edc47bd21.svn-base new file mode 100644 index 0000000..b96d3d5 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/46/46e4ad74482a96c8b6c375d849e7755edc47bd21.svn-base @@ -0,0 +1,96 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use Getopt::Long qw{GetOptions}; + +# ------------------------------------------------------------------------------ + +my ($u, @label); +GetOptions ('u' => \$u, 'L=s' => \@label); + +# Check existence of files +for my $i (0 .. 1) { + die $ARGV[$i], ': not found, abort' unless $ARGV[$i] and -f $ARGV[$i]; +} + +my ($old, $new) = @ARGV; + +if ($old =~ m#.svn/empty-file$#) { + print 'Skipping new file', "\n\n"; + +} elsif ($new =~ m#.svn/empty-file$#) { + print 'Skipping deleted file', "\n\n"; + +} elsif (-z $old) { + print 'Skipping as old file is empty (or does not exist)', "\n\n"; + +} elsif (-z $new) { + print 'Skipping as new file is empty (or deleted)', "\n\n"; + +} elsif (-B $new) { + print 'Skipping binary file', "\n\n"; + +} else { + # Print descriptions of files + if (@label >= 2) { + print '--- ', $label[0], "\n", '+++ ', $label[1], "\n\n"; + } + + # FCM_GRAPHIC_DIFF is the graphical diff tool command + my $cmd = (exists $ENV{FCM_GRAPHIC_DIFF} ? $ENV{FCM_GRAPHIC_DIFF} : 'xxdiff'); + + if ($cmd) { + my @options = (); + + # Set options for labels if appropriate + if (@label >= 2) { + if ($cmd eq 'tkdiff') { + # Use tkdiff + @options = ('-L', $label[0], '-L', $label[1]); + + } elsif ($cmd eq 'xxdiff') { + # Use xxdiff + @options = ('--title1', $label[0], '--title2', $label[1]); + } + } + + # Execute the command + my @command = ($cmd, @options, $old, $new); + exec (@command) or die 'Cannot execute: ', join (' ', @command); + } + + exit; +} + +__END__ + +=head1 NAME + +fcm_graphic_diff + +=head1 SYNOPSIS + + fcm_graphic_diff [-u] [-L OLD_DESC] [-L NEW_DESC] OLD NEW + +=head1 DESCRIPTION + +Wrapper script which invokes a graphical diff tool. Its interface is +compatible with the "svn diff" command and can be used in combination with +its "--diff-cmd" option. The command prints the OLD_DESC and NEW_DESC if +they are both set. The two arguments OLD and NEW must be set and are the +files to compare. The graphical diff tool invoked depends on the value of +the FCM_GRAPHIC_DIFF environment variable. The command exits if the +environment variable is not set. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/48/481c4d3777220f062b69219e464311f7d63f1d0c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/48/481c4d3777220f062b69219e464311f7d63f1d0c.svn-base new file mode 100644 index 0000000..576022f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/48/481c4d3777220f062b69219e464311f7d63f1d0c.svn-base @@ -0,0 +1,47 @@ +#!/bin/sh +# ------------------------------------------------------------------------------ +# NAME +# fcm_setup_konqueror +# +# SYNOPSIS +# fcm_setup_konqueror +# +# DESCRIPTION +# Set up Konqueror to use "fcm gui". +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +# Check number of arguments +script=`basename $0` +usage="$script: no argument required" +if (( $# != 0 )); then + echo "$usage, abort..." >&2 + exit 1 +fi + +filename=fcm_gui.desktop + +file=`dirname $0` +if [[ `basename $file` = bin ]]; then + file=`dirname $file` +fi +file=$file/etc/$filename + +if [[ ! -f $file ]]; then + echo "$script: $file not found, abort..." >&2 + exit 1 +fi + +dir=$HOME/.kde/share/applnk/.hidden +mkdir -p $dir +cd $dir +rm -f $filename # Always remove. +ln -s $file . + +echo "$script: finished" + +#EOF diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/48/48d6827a15a2e36f8e5da1239c140b34c844a9c5.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/48/48d6827a15a2e36f8e5da1239c140b34c844a9c5.svn-base new file mode 100644 index 0000000..0a7c9cc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/48/48d6827a15a2e36f8e5da1239c140b34c844a9c5.svn-base @@ -0,0 +1,376 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword; + +use Carp qw{croak}; +use Fcm::Config; +use Fcm::Exception; +use Fcm::Keyword::Config; +use Fcm::Keyword::Exception; +use URI; + +my $ENTRIES; + +my $PREFIX_OF_LOCATION_KEYWORD = 'fcm'; +my $PATTERN_OF_RESERVED_REVISION_KEYWORDS + = qr{\A (?:\d+|HEAD|BASE|COMMITTED|PREV|\{[^\}]+\}) \z}ixms; + +################################################################################ +# Returns the Fcm::Keyword::Entries object for storing the location entries +sub get_entries { + my ($reset) = @_; + if ($reset || !$ENTRIES) { + $ENTRIES = Fcm::Keyword::Config::get_entries('LOCATION_ENTRIES'); + } + return $ENTRIES; +} + +################################################################################ +# Returns a list of Fcm::Keyword::Entry::Location objects matching $in_loc +sub get_location_entries_for { + my ($in_loc) = @_; + my ($loc, $rev, @entry_trail_refs) = _parse_loc($in_loc); + return (map {$_->[0]} @entry_trail_refs); +} + +################################################################################ +# Returns the prefix of location keyword (with or without the delimiter). +sub get_prefix_of_location_keyword { + my ($with_delimiter) = @_; + return $PREFIX_OF_LOCATION_KEYWORD . ($with_delimiter ? ':' : ''); +} + +################################################################################ +# Expands (the keywords in) the specfied location (and REV), and returns them +sub expand { + my ($in_loc, $in_rev) = @_; + my ($loc, $rev) = _expand($in_loc, $in_rev); + return _unparse_loc($loc, $rev, $in_rev); +} + +################################################################################ +# Returns the corresponding browser URL for the input VC location +sub get_browser_url { + my ($in_loc, $in_rev) = @_; + + my ($loc, $rev, @entry_trail_refs) = _expand($in_loc, $in_rev); + if (!@entry_trail_refs) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: cannot be mapped to a browser URL", $in_loc, + )})); + } + + my @entries = map {$_->[0]} @entry_trail_refs; + my $location_component_pattern + = _get_browser_url_setting(\@entries, 'location_component_pattern'); + my $browser_url_template + = _get_browser_url_setting(\@entries, 'browser_url_template'); + my $browser_rev_template + = _get_browser_url_setting(\@entries, 'browser_rev_template'); + + if ( + $location_component_pattern + && $browser_url_template + && $browser_rev_template + ) { + my $uri = URI->new($loc); + my $sps = $uri->opaque(); + my @matches = $sps =~ $location_component_pattern; + if (@matches) { + my $result = $browser_url_template; + for my $field_number (1 .. @matches) { + my $match = $matches[$field_number - 1]; + $result =~ s/\{ $field_number \}/$match/xms; + } + my $rev_field = scalar(@matches) + 1; + if ($rev) { + my $rev_string = $browser_rev_template; + $rev_string =~ s/\{1\}/$rev/xms; + $result =~ s/\{ $rev_field \}/$rev_string/xms; + } + else { + $result =~ s/\{ $rev_field \}//xms; + } + return $result; + } + } + else { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: mapping templates not defined correctly", $in_loc, + )})); + } +} + +################################################################################ +# Returns a browser URL setting, helper function for get_browser_url() +sub _get_browser_url_setting { + my ($entries_ref, $setting) = @_; + my $getter = "get_$setting"; + for my $entry (@{$entries_ref}) { + my $setting = $entry->$getter(); + if ($setting) { + return $setting; + } + } + my $config = Fcm::Config->instance(); + return $config->setting('URL_BROWSER_MAPPING_DEFAULT', uc($setting)); +} + +################################################################################ +# Un-expands the specfied location (and REV) to keywords, and returns them +sub unexpand { + my ($in_loc, $in_rev) = @_; + my ($loc, $rev, @entry_trail_refs) = _parse_loc($in_loc, $in_rev); + if (@entry_trail_refs) { + my ($entry, $trail) = @{$entry_trail_refs[0]}; + if ($rev) { + GET_REV_KEY: + for my $entry_trail_ref (@entry_trail_refs) { + my ($e, $t) = @{$entry_trail_ref}; + my $rev_key + = $e->get_revision_entries()->get_entry_by_value($rev); + if ($rev_key) { + $rev = $rev_key->get_key(); + last GET_REV_KEY; + } + } + } + $loc = get_prefix_of_location_keyword(1) . $entry->get_key() . $trail; + return _unparse_loc($loc, $rev, $in_rev); + } + return _unparse_loc($in_loc, $in_rev, $in_rev); +} + +################################################################################ +# Expands (the keywords in) the specfied location (and REV), and returns them +sub _expand { + my ($in_loc, $in_rev) = @_; + my ($loc, $rev, @entry_trail_refs) = _parse_loc($in_loc, $in_rev); + if (@entry_trail_refs) { + my ($entry, $trail) = @{$entry_trail_refs[0]}; + $loc = $entry->get_value() . $trail; + if ($rev && $rev !~ $PATTERN_OF_RESERVED_REVISION_KEYWORDS) { + my $r; + GET_REV: + for my $entry_trail_ref (@entry_trail_refs) { + my ($e, $t) = @{$entry_trail_ref}; + $r = $e->get_revision_entries()->get_entry_by_key($rev); + if ($r) { + $rev = $r->get_value(); + last GET_REV; + } + } + if (!$r) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: %s: unknown revision keyword", + $loc, $rev, + )})); + } + } + } + return ($loc, $rev, @entry_trail_refs); +} + +################################################################################ +# Parses $in_loc (and $in_rev) +sub _parse_loc { + my ($in_loc, $in_rev) = @_; + if (!$in_loc) { + croak(Fcm::Exception->new({ + message => 'internal error: $in_loc not defined', + })); + } + if ($in_loc) { + if (!defined($in_rev)) { + my ($loc, $rev) = $in_loc =~ qr{\A (.+) \@ ([^/\@]+) \z}xms; + if ($loc && $rev) { + return ($loc, $rev, _get_loc_entry($loc)); + } + else { + return ($in_loc, $in_rev, _get_loc_entry($in_loc)); + } + } + return ($in_loc, $in_rev, _get_loc_entry($in_loc)); + } + return; +} + +################################################################################ +# Returns a list of keyword entries/trailing path pairs for the input location +sub _get_loc_entry { + my ($loc) = @_; + if ($loc) { + my $uri = URI->new($loc); + if ( + $uri->scheme() + && $uri->scheme() eq get_prefix_of_location_keyword() + ) { + my ($key, $trail) = $uri->opaque() =~ qr{\A ([^/\@]+) (.*) \z}xms; + my $entry = get_entries()->get_entry_by_key($key); + if (!$entry || !$entry->get_value()) { + die(Fcm::Keyword::Exception->new({message => sprintf( + "%s: unknown FCM location keyword", $loc, + )})); + } + $loc = $entry->get_value() . ($trail ? $trail : q{}); + } + my @entry_trail_pairs = (); + my $lead = $loc; + GET_ENTRY: + while ($lead) { + my $entry = get_entries()->get_entry_by_value($lead); + if ($entry) { + my $trail = substr($loc, length($lead)); + push @entry_trail_pairs, [$entry, $trail]; + } + if (!($lead =~ s{/+ [^/]* \z}{}xms)) { + last GET_ENTRY; + } + } + if (@entry_trail_pairs) { + return @entry_trail_pairs; + } + else { + return; + } + } + return; +} + +################################################################################ +# If $in_rev, returns (LOC, REV). Otherwise, returns LOC@REV +sub _unparse_loc { + my ($loc, $rev, $in_rev) = @_; + if (!$loc) { + return; + } + return ($in_rev ? ($loc, $rev) : join(q{@}, $loc, ($rev ? $rev : ()))); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword + +=head1 SYNOPSIS + + use Fcm::Keyword; + + $loc = Fcm::Keyword::expand('fcm:namespace/path@rev-keyword'); + $loc = Fcm::Keyword::unexpand('svn://host/namespace/path@1234'); + + ($loc, $rev) = Fcm::Keyword::expand('fcm:namespace/path', 'rev-keyword'); + ($loc, $rev) = Fcm::Keyword::unexpand('svn://host/namespace/path', 1234); + + $loc = Fcm::Keyword::get_browser_url('fcm:namespace/path'); + $loc = Fcm::Keyword::get_browser_url('svn://host/namespace/path'); + + $loc = Fcm::Keyword::get_browser_url('fcm:namespace/path@1234'); + $loc = Fcm::Keyword::get_browser_url('svn://host/namespace/path@1234'); + + $loc = Fcm::Keyword::get_browser_url('fcm:namespace/path', 1234); + $loc = Fcm::Keyword::get_browser_url('svn://host/namespace/path', 1234); + + $entries = Fcm::Keyword::get_entries(); + +=head1 DESCRIPTION + +This module contains utilities to expand and unexpand FCM location and revision +keywords. + +=head1 FUNCTIONS + +=over 4 + +=item expand($loc) + +Expands FCM keywords in $loc and returns the result. + +If $loc is a I scheme URI, the leading part (before any "/" or "@" +characters) of the URI opaque is the namespace of a FCM location keyword. This +is expanded into the actual value. Optionally, $loc can be suffixed with a peg +revision (an "@" followed by any characters). If a peg revision is a FCM +revision keyword, it is expanded into the actual revision. + +=item expand($loc,$rev) + +Same as C, but $loc should not contain a peg revision. Returns a +list containing the expanded version of $loc and $rev. + +=item get_browser_url($loc) + +Given a repository $loc in a known keyword namespace, returns the corresponding +URL for the code browser. + +Optionally, $loc can be suffixed with a peg revision (an "@" followed by any +characters). + +=item get_browser_url($loc,$rev) + +Same as get_browser_url($loc), but the revision should be specified using $rev +but not pegged with $loc. + +=item get_entries([$reset]) + +Returns the L object for storing +location keyword entries. If $reset if true, reloads the entries. + +=item get_location_entries_for($loc) + +Returns a list of L +objects matching $loc. + +=item get_prefix_of_location_keyword($with_delimiter) + +Returns the prefix of a FCM location keyword, (currently "fcm"). If +$with_delimiter is specified and is true, returns the prefix with the delimiter, +(currently "fcm:"). + +=item unexpand($loc) + +Does the opposite of expand($loc). Returns the FCM location keyword equivalence +of $loc. If the $loc can be mapped using 2 or more namespaces, the namespace +that results in the longest substitution is used. Optionally, $loc can be +suffixed with a peg revision (an "@" followed by any characters). If a peg +revision is a known revision, it is turned into its corresponding revision +keyword. + +=item unexpand($loc,$rev) + +Same as unexpand($loc), but $loc should not contain a peg revision. Returns a +list containing the unexpanded version of $loc and $rev + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +Functions in this module may die() with this exception when it fails to expand +a keyword. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/49/49d7a960d29a0fac53ee6ef7dfe9fd36ddda6635.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/49/49d7a960d29a0fac53ee6ef7dfe9fd36ddda6635.svn-base new file mode 100644 index 0000000..f549156 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/49/49d7a960d29a0fac53ee6ef7dfe9fd36ddda6635.svn-base @@ -0,0 +1,245 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Subcommand; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::Util::ClassLoader; + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + # Returns the long description of this subcommand + 'description', + # Returns the class of the invoker of this subcommand + 'invoker_class', + # Returns the extra config to be given to the invoker of this subcommand + 'invoker_config', + # Returns the names of this subcommand + 'names', + # Returns the options of this subcommand + 'options', + # Returns the synopsis of this subcommand + 'synopsis', + # Returns the usage of this subcommand + 'usage', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + if (defined($self->{$key})) { + if (ref($self->{$key}) eq 'ARRAY') { + return (wantarray() ? @{$self->{$key}} : $self->{$key}); + } + else { + return $self->{$key}; + } + } + else { + return; + } + } +} + +################################################################################ +# Returns true if this subcommand represents a command in the CM sub-system +sub is_vc { + my ($self) = @_; + return $self->{is_vc}; +} + +################################################################################ +# Returns true if $string matches a name of this subcommand +sub has_a_name { + my ($self, $string) = @_; + if ($self->get_names() && ref($self->get_names()) eq 'ARRAY') { + my %name_of = map {$_, 1} @{$self->get_names()}; + return exists($name_of{$string}); + } + else { + return; + } +} + +################################################################################ +# Invokes this subcommand based on current @ARGV +sub get_invoker { + my ($self, $command) = @_; + my %options = (); + if (($self->get_options())) { + my $problem = q{}; + local($SIG{__WARN__}) = sub { + ($problem) = @_; + }; + my $success = GetOptions( + \%options, + (map {$_->get_arg_for_getopt_long()} ($self->get_options())), + ); + if (!$success) { + croak(Fcm::CLI::Exception->new({message => sprintf( + "%s: option parse failed: %s", $command, $problem, + )})); + } + } + my $invoker_class + = $self->get_invoker_class() ? $self->get_invoker_class() + : 'Fcm::CLI::Invoker' + ; + Fcm::Util::ClassLoader::load($invoker_class); + my $invoker = $invoker_class->new({ + command => $command, + options => \%options, + arguments => [@ARGV], + }); + return $invoker; +} + +################################################################################ +# Returns a simple string representation of this subcommand +sub as_string { + my ($self) = @_; + # FIXME: can do with using Text::Template or Perl6::Form + if ( + $self->get_names() + && ref($self->get_names()) eq 'ARRAY' + && @{$self->get_names()} + ) { + my @names = $self->get_names(); + my $return = $names[0]; + for my $i (1 .. $#names) { + if ($names[$i]) { + $return + .= $i == 1 ? q{ (} . $names[$i] + : q{, } . $names[$i] + ; + } + if ($i == $#names) { + $return .= q{)}; + } + } + return $return; + } + else { + return q{}; + } +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Subcommand + +=head1 SYNOPSIS + + use Fcm::CLI::Subcommand; + $subcommand = Fcm::CLI::Subcommand->new({ + names => ['build', 'bld'], + options => [ + Fcm::CLI::Option->new( + # ... some arguments ... + ), + # ... more options + ], + synopsis => 'invokes the build system', + description => $description, + usage => '[OPTIONS] [CONFIG]', + invoker_class => $invoker_class, + invoker_config => { + option1 => $option1, + # ... more options + }, + }); + $boolean = $subcommand->has_a_name($string); + $invoker_class = $subcommand->get_invoker_class(); + +=head1 DESCRIPTION + +An object of this class is used to store the configuration of a subcommand of +the FCM CLI. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor. + +=item get_description() + +Returns the long description of this subcommand. + +=item get_invoker_class() + +Returns the invoker class of this subcommand, which should be a sub-class of +L. + +=item get_invoker_cconfig() + +Returns a reference to a hash containing the extra configuration to be given to +the constructor of the invoker of this subcommand. + +=item get_names() + +Returns an array containing the names of this subcommand. + +=item get_options() + +Returns an array containing the options of this subcommand. Each element of +the array should be a L object. + +=item get_synopsis() + +Returns a short synopsis of this subcommand. + +=item get_usage() + +Returns a short usage statement of this subcommand. + +=item is_vc() + +Returns true if this subcommand represents commands in the underlying VC system. + +=item has_a_name($string) + +Returns true if a name in C<$self-Eget_names()> matches $string. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method may croak() with this exception. + +=back + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/4b/4b3585de11351c4b8f44d823f1022a00aa996ecc.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/4b/4b3585de11351c4b8f44d823f1022a00aa996ecc.svn-base new file mode 100644 index 0000000..23332e3 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/4b/4b3585de11351c4b8f44d823f1022a00aa996ecc.svn-base @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Config; +use Fcm::Keyword::Entries; +use Test::More qw{no_plan}; + +my %VALUE_OF = ( + foo => 'fcm-test://foo/foo', + bar => 'fcm-test://bar/bar', + baz => 'fcm-test://baz/baz', +); + +main(); + +sub main { + my $class = 'Fcm::Keyword::Loader::Config::Location'; + use_ok($class); + test_constructor($class); + test_load_to($class); +} + +################################################################################ +# Tests simple usage of the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = "constructor"; + my $loader = $class->new(); + isa_ok($loader, $class); + is($loader->get_source(), 'Fcm::Config', "$prefix: get_source()"); +} + +################################################################################ +# Tests loading to an Fcm::Keyword::Entries object +sub test_load_to { + my ($class) = @_; + my $prefix = 'load to'; + my $config = Fcm::Config->instance(); + for my $key (keys(%VALUE_OF)) { + $config->setting(['URL', $key], $VALUE_OF{$key}); + } + my $loader = $class->new(); + my $entries = Fcm::Keyword::Entries->new({ + entry_class => 'Fcm::Keyword::Entry::Location', + }); + isnt($loader->load_to($entries), 0, "$prefix: number loaded"); + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->get_entry_by_key($key); + if ($entry) { + is($entry->get_key(), uc($key), "$prefix: by key: $key"); + is($entry->get_value(), $VALUE_OF{$key}, "$prefix: by value: $key"); + is( + $entries->get_entry_by_value($VALUE_OF{$key}), + $entry, + "$prefix: by key: $key: object", + ); + } + else { + fail("$prefix: by key: $key"); + } + } +} + +# TODO: tests loading of browser mapping + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/52/5215b7b42b48f1a51a1ae5dedf975d7cd206c22c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/52/5215b7b42b48f1a51a1ae5dedf975d7cd206c22c.svn-base new file mode 100644 index 0000000..7722685 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/52/5215b7b42b48f1a51a1ae5dedf975d7cd206c22c.svn-base @@ -0,0 +1,66 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Fcm::CLI; +use Fcm::Interactive; + +if (!caller()) { + main(@ARGV); +} + +sub main { + local(@ARGV) = @_; + if (@ARGV && $ARGV[0] eq 'gui-internal') { + shift(@ARGV); + Fcm::Interactive::set_impl( + 'Fcm::Interactive::InputGetter::GUI', + {geometry => shift(@ARGV)}, + ); + } + Fcm::CLI::invoke(); +} + +__END__ + +=head1 NAME + +fcm + +=head1 SYNOPSIS + +fcm SUBCOMMAND [OPTIONS] [ARGUMENTS] + +=head1 OVERVIEW + +B is the command line client for code management commands, the extract +system and the build system of the Flexible Configuration Management (FCM) +system. For full detail of the system, please refer to the FCM user guide, +which you should receive with this distribution in both HTML and PDF formats. + +Run "fcm help" to access the built-in tool documentation. + +=head1 AUTHOR + +FCM Team L. +Please feedback any bug reports or feature requests to us by e-mail. + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +You can use this release of B freely under the terms of the FCM LICENSE, +which you should receive with this distribution. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/52/5279fc2d2b2c935295c96e8e69596d33543e341d.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/52/5279fc2d2b2c935295c96e8e69596d33543e341d.svn-base new file mode 100644 index 0000000..8e592d7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/52/5279fc2d2b2c935295c96e8e69596d33543e341d.svn-base @@ -0,0 +1,172 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI; + +use Carp qw{croak}; +use Fcm::CLI::Config; +use Fcm::CLI::Exception; +use Fcm::Util::ClassLoader; +use File::Basename qw{basename}; +use Getopt::Long qw{GetOptions}; +use Scalar::Util qw{blessed}; + +################################################################################ +# Invokes the FCM command line interface +sub invoke { + local(@ARGV) = @ARGV; + my $config = Fcm::CLI::Config->instance(); + my $subcommand_name = @ARGV ? shift(@ARGV) : q{}; + my $subcommand = $config->get_subcommand_of($subcommand_name); + eval { + if (!$subcommand) { + croak(Fcm::CLI::Exception->new({message => 'unknown command'})); + } + my ($opts_ref, $args_ref, $is_help) = _parse_argv_using($subcommand); + my ($invoker_class, $invoker); + if ($is_help) { + $invoker_class + = _load_invoker_class_of($config->get_subcommand_of(q{})); + $invoker = $invoker_class->new({ + command => $subcommand_name, + arguments => [$subcommand_name], + }); + } + else { + $invoker_class = _load_invoker_class_of($subcommand); + $invoker = $invoker_class->new({ + command => $subcommand_name, + options => $opts_ref, + arguments => $args_ref, + ( + $subcommand->get_invoker_config() + ? %{$subcommand->get_invoker_config()} + : () + ), + }); + } + $invoker->invoke(); + }; + if ($@) { + if (Fcm::CLI::Exception->caught($@)) { + die(sprintf( + qq{%s%s: %s\nType "%s help%s" for usage\n}, + basename($0), + ($subcommand_name ? qq{ $subcommand_name} : q{}), + $@->get_message(), + basename($0), + defined($subcommand) ? qq{ $subcommand_name} : q{}, + )); + } + else { + die($@); + } + } +} + +################################################################################ +# Parses options in @ARGV using the options settings of a subcommand +sub _parse_argv_using { + my ($subcommand) = @_; + my %options = (); + my $is_help = undef; + if (($subcommand->get_options())) { + my $problem = q{}; + local($SIG{__WARN__}) = sub { + ($problem) = @_; + }; + my $success = GetOptions( + \%options, + (map {$_->get_arg_for_getopt_long()} ($subcommand->get_options())), + ); + if (!$success) { + croak(Fcm::CLI::Exception->new({message => sprintf( + "option parse failed: %s", $problem, + )})); + } + + OPTION: + for my $option ($subcommand->get_options()) { + if (!exists($options{$option->get_name()})) { + next OPTION; + } + if ($option->is_help()) { + $is_help = 1; + } + if ( + $option->has_arg() == $option->ARRAY_ARG + && $option->get_delimiter() + ) { + $options{$option->get_name()} = [split( + $option->get_delimiter(), + join( + $option->get_delimiter(), + @{$options{$option->get_name()}}, + ), + )]; + } + } + } + return (\%options, [@ARGV], $is_help); +} + +################################################################################ +# Loads and returns the invoker class of a subcommand +sub _load_invoker_class_of { + my ($subcommand) = @_; + my $invoker_class + = $subcommand->get_invoker_class() ? $subcommand->get_invoker_class() + : 'Fcm::CLI::Invoker' + ; + return Fcm::Util::ClassLoader::load($invoker_class); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI + +=head1 SYNOPSIS + + use Fcm::CLI + Fcm::CLI::invoke(); + +=head1 DESCRIPTION + +Invokes the FCM command line interface. + +=head1 FUNCTIONS + +=over 4 + +=item invoke() + +Invokes the FCM command line interface. + +=back + +=head1 TO DO + +Move option/argument parsing to L? + +Use an OO interface? + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/53/537e23b19de0f26f20bb5c396c7989af6c3d83a6.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/53/537e23b19de0f26f20bb5c396c7989af6c3d83a6.svn-base new file mode 100644 index 0000000..1eeee89 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/53/537e23b19de0f26f20bb5c396c7989af6c3d83a6.svn-base @@ -0,0 +1,681 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CfgFile +# +# DESCRIPTION +# This class is used for reading and writing FCM config files. A FCM config +# file is a line-based text file that provides information on how to perform +# a particular task using the FCM system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CfgFile; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use Carp; +use File::Basename; +use File::Path; +use File::Spec; + +# FCM component modules +use Fcm::Base; +use Fcm::CfgLine; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Util; + +# List of property methods for this class +my @scalar_properties = ( + 'actual_src', # actual source of configuration file + 'lines', # list of lines, Fcm::CfgLine objects + 'pegrev', # peg revision of configuration file + 'src', # source of configuration file + 'type', # type of configuration file + 'version', # version of configuration file +); + +# Local module variables +my $expand_type = 'bld|ext'; # config file type that needs variable expansions + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::CfgFile->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CfgFile class. See above +# for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + bless $self, $class; + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + if (@_) { + $self->{$name} = $_[0]; + } + + if (not defined $self->{$name}) { + if ($name eq 'lines') { + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $mtime = $obj->mtime (); +# +# DESCRIPTION +# This method returns the modified time of the configuration file source. +# ------------------------------------------------------------------------------ + +sub mtime { + my $self = shift; + my $mtime = undef; + + if (-f $self->src) { + $mtime = (stat $self->src)[9]; + } + + return $mtime; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $read = $obj->read_cfg (); +# +# DESCRIPTION +# This method reads the current configuration file. It returns the number of +# lines read from the config file, or "undef" if it fails. The result is +# placed in the LINES array of the current instance, and can be accessed via +# the "lines" method. +# ------------------------------------------------------------------------------ + +sub read_cfg { + my $self = shift; + + my @lines = $self->_get_cfg_lines; + + # List of CFG types that need INC declarations expansion + my %exp_inc = (); + for (split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_EXP_INC'))) { + $exp_inc{uc ($_)} = 1; + } + + # List of CFG labels that are reserved keywords + my %cfg_keywords = (); + for (split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD'))) { + $cfg_keywords{$self->cfglabel ($_)} = 1; + } + + # Loop each line, to separate lines into label : value pairs + my $cont = undef; + my $here = undef; + for my $line_num (1 .. @lines) { + my $line = $lines[$line_num - 1]; + chomp $line; + + my $label = ''; + my $value = ''; + my $comment = ''; + + # If this line is a continuation, set $start to point to the line that + # starts this continuation. Otherwise, set $start to undef + my $start = defined ($cont) ? $self->lines->[$cont] : undef; + my $warning = undef; + + if ($line =~ /^(\s*#.*)$/) { # comment line + $comment = $1; + + } elsif ($line =~ /\S/) { # non-blank line + if (defined $cont) { + # Previous line has a continuation mark + $value = $line; + + # Separate value and comment + if ($value =~ s/((?:\s+|^)#\s+.*)$//) { + $comment = $1; + } + + # Remove leading spaces + $value =~ s/^\s*\\?//; + + # Expand environment variables + my $warn; + ($value, $warn) = $self->_expand_variable ($value, 1) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + + # Expand internal variables + ($value, $warn) = $self->_expand_variable ($value, 0) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + + # Get "line" that begins the current continuation + my $v = $start->value . $value; + $v =~ s/\\$//; + $start->value ($v); + + } else { + # Previous line does not have a continuation mark + if ($line =~ /^\s*(\S+)(?:\s+(.*))?$/) { + # Check line contains a valid label:value pair + $label = $1; + $value = defined ($2) ? $2 : ''; + + # Separate value and comment + if ($value =~ s/((?:\s+|^)#\s+.*)$//) { + $comment = $1; + } + + # Remove trailing spaces + $value =~ s/\s+$//; + + # Value begins with $HERE? + $here = ($value =~ /\$\{?HERE\}?(?:[^A-Z_]|$)/); + + # Expand environment variables + my $warn; + ($value, $warn) = $self->_expand_variable ($value, 1) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + + # Expand internal variables + ($value, $warn) = $self->_expand_variable ($value, 0) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + } + } + + # Determine whether current line ends with a continuation mark + if ($value =~ s/\\$//) { + $cont = scalar (@{ $self->lines }) unless defined $cont; + + } else { + $cont = undef; + } + } + + if ( defined($self->type()) + && exists($exp_inc{uc($self->type())}) + && uc($start ? $start->label() : $label) eq $self->cfglabel('INC') + && !defined($cont) + ) { + # Current configuration file requires expansion of INC declarations + # The start/current line is an INC declaration + # The current line is not a continuation or is the end of the continuation + + # Get lines from an "include" configuration file + my $src = ($start ? $start->value : $value); + $src .= '@' . $self->pegrev if $here and $self->pegrev; + + if ($src) { + # Invoke a new instance to read the source + my $cfg = Fcm::CfgFile->new ( + SRC => expand_tilde ($src), TYPE => $self->type, + ); + + $cfg->read_cfg; + + # Add lines to the lines array in the current configuration file + $comment = 'INC ' . $src . ' '; + push @{$self->lines}, Fcm::CfgLine->new ( + comment => $comment . '# Start', + number => ($start ? $start->number : $line_num), + src => $self->actual_src, + warning => $warning, + ); + push @{ $self->lines }, @{ $cfg->lines }; + push @{$self->lines}, Fcm::CfgLine->new ( + comment => $comment . '# End', + src => $self->actual_src, + ); + + } else { + push @{$self->lines}, Fcm::CfgLine->new ( + number => $line_num, + src => $self->actual_src, + warning => 'empty INC declaration.' + ); + } + + } else { + # Push label:value pair into lines array + push @{$self->lines}, Fcm::CfgLine->new ( + label => $label, + value => ($label ? $value : ''), + comment => $comment, + number => $line_num, + src => $self->actual_src, + warning => $warning, + ); + } + + next if defined $cont; # current line not a continuation + + my $slabel = ($start ? $start->label : $label); + my $svalue = ($start ? $start->value : $value); + next unless $slabel; + + # Check config file type and version + if (index (uc ($slabel), $self->cfglabel ('CFGFILE')) == 0) { + my @words = split /$Fcm::Config::DELIMITER_PATTERN/, $slabel; + shift @words; + + my $name = @words ? lc ($words[0]) : 'type'; + + if ($self->can ($name)) { + $self->$name ($svalue); + } + } + + # Set internal variable + $slabel =~ s/^\%//; # Remove leading "%" from label + + $self->config->variable ($slabel, $svalue) + unless exists $cfg_keywords{$slabel}; + } + + # Report and reset warnings + # ---------------------------------------------------------------------------- + for my $line (@{ $self->lines }) { + w_report $line->format_warning if $line->warning; + $line->warning (undef); + } + + return @{ $self->lines }; + +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->print_cfg ($file, [$force]); +# +# DESCRIPTION +# This method prints the content of current configuration file. If no +# argument is specified, it prints output to the standard output. If $file is +# specified, and is a writable file name, the output is sent to the file. If +# the file already exists, its content is compared to the current output. +# Nothing will be written if the content is unchanged unless $force is +# specified. Otherwise, for typed configuration files, the existing file is +# renamed using a prefix that contains its last modified time. The method +# returns 1 if there is no error. +# ------------------------------------------------------------------------------ + +sub print_cfg { + my ($self, $file, $force) = @_; + + # Count maximum number of characters in the labels, (for pretty printing) + my $max_label_len = 0; + for my $line (@{ $self->lines }) { + next unless $line->label; + my $label_len = length $line->label; + $max_label_len = $label_len if $label_len > $max_label_len; + } + + # Output string + my $out = ''; + + # Append each line of the config file to the output string + for my $line (@{ $self->lines }) { + $out .= $line->print_line ($max_label_len - length ($line->label) + 1); + $out .= "\n"; + } + + if ($out) { + my $old_select = select; + + # Open file if necessary + if ($file) { + # Make sure the host directory exists and is writable + my $dirname = dirname $file; + if (not -d $dirname) { + print 'Make directory: ', $dirname, "\n" if $self->verbose; + mkpath $dirname; + } + croak $dirname, ': cannot write to config file directory, abort' + unless -d $dirname and -w $dirname; + + if (-f $file and not $force) { + if (-r $file) { + # Read old config file to see if content has changed + open IN, '<', $file or croak $file, ': cannot open (', $!, '), abort'; + my $in_lines = ''; + while (my $line = ) { + $in_lines .= $line; + } + close IN or croak $file, ': cannot close (', $!, '), abort'; + + # Return if content is up-to-date + if ($in_lines eq $out) { + print 'No change in ', lc ($self->type), ' cfg: ', $file, "\n" + if $self->verbose > 1 and $self->type; + return 1; + } + } + + # If config file already exists, make sure it is writable + if (-w $file) { + if ($self->type) { + # Existing config file writable, rename it using its time stamp + my $mtime = (stat $file)[9]; + my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5]; + my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_', + $year + 1900, $mon + 1, $mday, $hour, $min, $sec; + my $oldfile = File::Spec->catfile ( + $dirname, $timestamp . basename ($file) + ); + rename $file, $oldfile; + print 'Rename existing ', lc ($self->type), ' cfg: ', + $oldfile, "\n" if $self->verbose > 1; + } + + } else { + # Existing config file not writable, throw an error + croak $file, ': config file not writable, abort'; + } + } + + # Open file and select file handle + open OUT, '>', $file + or croak $file, ': cannot open config file (', $!, '), abort'; + select OUT; + } + + # Print output + print $out; + + # Close file if necessary + if ($file) { + select $old_select; + close OUT or croak $file, ': cannot close config file (', $!, '), abort'; + + if ($self->type and $self->verbose > 1) { + print 'Generated ', lc ($self->type), ' cfg: ', $file, "\n"; + + } elsif ($self->verbose > 2) { + print 'Generated cfg: ', $file, "\n"; + } + } + + } else { + # Warn if nothing to print + my $warning = 'Empty configuration'; + $warning .= ' - nothing written to file: ' . $file if $file; + carp $warning if $self->type; + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @lines = $self->_get_cfg_lines (); +# +# DESCRIPTION +# This internal method reads from a configuration file residing in a +# Subversion repository or in the normal file system. +# ------------------------------------------------------------------------------ + +sub _get_cfg_lines { + my $self = shift; + my @lines = (); + + my $verbose = $self->verbose; + + my ($src) = $self->src(); + if ($src =~ qr{\A([A-Za-z][\w\+-\.]*):}xms) { # is a URI + $src = Fcm::Keyword::expand($src); + # Config file resides in a SVN repository + # -------------------------------------------------------------------------- + # Set URL source and version + my $rev = 'HEAD'; + + # Extract version from source if it exists + if ($src =~ s{\@ ([^\@]+) \z}{}xms) { + $rev = $1; + } + + $src = Fcm::Util::tidy_url($src); + + # Check whether URL is a config file + my $rc; + my @cmd = (qw/svn cat/, $src . '@' . $rev); + @lines = &run_command ( + \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', + ); + + # Error in "svn cat" command + if ($rc) { + # See whether specified config file is a known type + my %cfgname = %{ $self->setting ('CFG_NAME') }; + my $key = uc $self->type; + my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; + + # If config file is a known type, specified URL may be a directory + if ($file) { + # Check whether a config file with a default name exists in the URL + my $path = $src . '/' . $file; + my @cmd = (qw/svn cat/, $path . '@' . $rev); + + @lines = &run_command ( + \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', + ); + + # Check whether a config file with a default name exists under the "cfg" + # sub-directory of the URL + if ($rc) { + my $cfgdir = $self->setting (qw/DIR CFG/); + $path = $src . '/' . $cfgdir . '/' . $file; + my @cmd = (qw/svn cat/, $path . '@' . $rev); + + @lines = &run_command ( + \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', + ); + } + + $src = $path unless $rc; + } + } + + if ($rc) { + # Error in "svn cat" + croak 'Unable to locate config file from "', $self->src, '", abort'; + + } else { + # Print diagnostic, if necessary + if ($verbose and $self->type and $self->type =~ /$expand_type/) { + print 'Config file (', $self->type, '): ', $src; + print '@', $rev if $rev; + print "\n"; + } + } + + # Record the actual source location + $self->pegrev ($rev); + $self->actual_src ($src); + + } else { + # Config file resides in the normal file system + # -------------------------------------------------------------------------- + my $src = $self->src; + + if (-d $src) { # Source is a directory + croak 'Config file "', $src, '" is a directory, abort' if not $self->type; + + # Get name of the config file by looking at the type + my %cfgname = %{ $self->setting ('CFG_NAME') }; + my $key = uc $self->type; + my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; + + if ($file) { + my $cfgdir = $self->setting (qw/DIR CFG/); + + # Check whether a config file with a default name exists in the + # specified path, then check whether a config file with a default name + # exists under the "cfg" sub-directory of the specified path + if (-f File::Spec->catfile ($self->src, $file)) { + $src = File::Spec->catfile ($self->src, $file); + + } elsif (-f File::Spec->catfile ($self->src, $cfgdir, $file)) { + $src = File::Spec->catfile ($self->src, $cfgdir, $file); + + } else { + croak 'Unable to locate config file from "', $self->src, '", abort'; + } + + } else { + croak 'Unknown config file type "', $self->type, '", abort'; + } + } + + if (-r $src) { + open FILE, '<', $src; + print 'Config file (', $self->type, '): ', $src, "\n" + if $verbose and $self->type and $self->type =~ /$expand_type/; + + @lines = readline 'FILE'; + close FILE; + + } else { + croak 'Unable to read config file "', $src, '", abort'; + } + + # Record the actual source location + $self->actual_src ($src); + } + + return @lines; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_expand_variable ($string, $env[, \%recursive]); +# +# DESCRIPTION +# This internal method expands variables in $string. If $env is true, it +# expands environment variables. Otherwise, it expands local variables. If +# %recursive is set, it indicates that this method is being called +# recursively. In which case, it must not attempt to expand a variable that +# exists in the keys of %recursive. +# ------------------------------------------------------------------------------ + +sub _expand_variable { + my ($self, $string, $env, $recursive) = @_; + + # Pattern for environment/local variable + my @patterns = $env + ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#) + : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#); + + my $ret = ''; + my $warning = undef; + while ($string) { + # Find the first match in $string + my ($prematch, $match, $postmatch, $var_label); + for my $pattern (@patterns) { + next unless $string =~ /$pattern/; + if ((not defined $prematch) or length ($`) < length ($prematch)) { + $prematch = $`; + $match = $&; + $var_label = $1; + $postmatch = $'; + } + } + + if ($match) { + $ret .= $prematch; + $string = $postmatch; + + # Get variable value from environment or local configuration + my $variable = $env + ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef) + : $self->config->variable ($var_label); + + if ($env and $var_label eq 'HERE' and not defined $variable) { + $variable = dirname ($self->actual_src); + $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable); + } + + # Substitute match with value of variable + if (defined $variable) { + my $cyclic = 0; + if ($recursive) { + if (exists $recursive->{$var_label}) { + $cyclic = 1; + + } else { + $recursive->{$var_label} = 1; + } + + } else { + $recursive = {$var_label => 1}; + } + + if ($cyclic) { + $warning .= ', ' if $warning; + $warning .= $match . ': cyclic dependency, variable not expanded'; + $ret .= $variable; + + } else { + my ($r, $w) = $self->_expand_variable ($variable, $env, $recursive); + $ret .= $r; + if ($w) { + $warning .= ', ' if $warning; + $warning .= $w; + } + } + + } else { + $warning .= ', ' if $warning; + $warning .= $match . ': variable not expanded'; + $ret .= $match; + } + + } else { + $ret .= $string; + $string = ""; + } + } + + return ($ret, $warning); +} + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/5b/5b83a31b2fc154cfcd4bfc020fdcdc48c0ad8cb5.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/5b/5b83a31b2fc154cfcd4bfc020fdcdc48c0ad8cb5.svn-base new file mode 100644 index 0000000..6d19012 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/5b/5b83a31b2fc154cfcd4bfc020fdcdc48c0ad8cb5.svn-base @@ -0,0 +1,31 @@ +=head1 NAME + +fcm commit (ci) + +=head1 SYNOPSIS + + fcm commit [OPTIONS] [PATH ...] + +Send changes from your working copy to the repository. Invoke your favourite +editor to prompt you for a commit log message. Update your working copy +following the commit. + +=head1 OPTIONS + +=over 4 + +=item --dry-run + +Allows you to add to the commit message without committing. + +=item --svn-non-interactive + +Do no interactive prompting at commit time. + +=item --password arg + +Specify a password ARG. + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/5c/5c6574dd5848774dd1c7cc7cf2c3f3e8fa80d09b.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/5c/5c6574dd5848774dd1c7cc7cf2c3f3e8fa80d09b.svn-base new file mode 100644 index 0000000..27470e2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/5c/5c6574dd5848774dd1c7cc7cf2c3f3e8fa80d09b.svn-base @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Keyword::Entries; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Formatter::Entries'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $formatter = $class->new(); + isa_ok($formatter, $class, $prefix); + my $entries = Fcm::Keyword::Entries->new(); + $entries->add_entry('foo', 'food'); + $entries->add_entry('bar', 'barley'); + is($formatter->format($entries), "BAR = barley\nFOO = food\n", + "$prefix: format"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/62/62cc8c95e73099e14c2068f0f4fed08ff185adbf.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/62/62cc8c95e73099e14c2068f0f4fed08ff185adbf.svn-base new file mode 100644 index 0000000..3c9d7d3 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/62/62cc8c95e73099e14c2068f0f4fed08ff185adbf.svn-base @@ -0,0 +1,110 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Loader::Config::Revision; + +use Fcm::Config; + +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns the namespace where the revision keywords belong +sub get_namespace { + my ($self) = @_; + return $self->{namespace}; +} + +################################################################################ +# Returns 'Fcm::Config' +sub get_source { + my ($self) = @_; + return 'Fcm::Config'; +} + +################################################################################ +# Loads revision keywords from Fcm::Config to $entries +sub load_to { + my ($self, $entries) = @_; + my $load_counter = 0; + my $config = $self->get_source()->instance(); + my $rev_keyword_ref = $config->setting( + qw/URL_REVISION/, + uc($self->get_namespace()), + ); + if ($rev_keyword_ref) { + for my $key (keys(%{$rev_keyword_ref})) { + $entries->add_entry($key, $rev_keyword_ref->{$key}); + $load_counter++; + } + } + return ($config->is_initialising() ? 0 : defined($load_counter)); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Loader::Config::Revision + +=head1 SYNOPSIS + + $loader = Fcm::Keyword::Loader::Config::Revision->new({namespace => $name}); + $loader->load_to($entries); + +=head1 DESCRIPTION + +Loads revision keywords from L into a +L object containing +L objects. + +=head1 METHODS + +=over 4 + +=item C $namespace})> + +Constructor. The argument $namespace is the namespace where the revision +keywords belong. + +=item get_namespace() + +Returns the namespace where the revision keywords belong. + +=item get_source() + +Returns the string "L". + +=item load_to($entries) + +Loads revision keywords in the namespace given by C<$self-Eget_namespace()> +from L to $entries. Returns true on success. (However, +if L is initialising, returns false to force a reload +next time.) + +=back + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/62/62f4c5c726ce2d26f3cdd765fc85fb25fa3a532e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/62/62f4c5c726ce2d26f3cdd765fc85fb25fa3a532e.svn-base new file mode 100644 index 0000000..4a2f710 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/62/62f4c5c726ce2d26f3cdd765fc85fb25fa3a532e.svn-base @@ -0,0 +1,333 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CfgLine +# +# DESCRIPTION +# This class is used for grouping the settings in each line of a FCM +# configuration file. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CfgLine; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use File::Basename; + +# In-house modules +use Fcm::Base; +use Fcm::Config; +use Fcm::Util; + +# List of property methods for this class +my @scalar_properties = ( + 'bvalue', # line value, in boolean + 'comment', # (in)line comment + 'error', # error message for incorrect usage while parsing the line + 'label', # line label + 'line', # content of the line + 'number', # line number in source file + 'parsed', # has this line been parsed (by the extract/build system)? + 'prefix', # optional prefix for line label + 'slabel', # label without the optional prefix + 'src', # name of source file + 'value', # line value + 'warning', # warning message for deprecated usage +); + +# Useful variables +our $COMMENT_RULER = '-' x 78; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = Fcm::CfgLine->comment_block (@comment); +# +# DESCRIPTION +# This method returns a list of Fcm::CfgLine objects representing a comment +# block with the comment string @comment. +# ------------------------------------------------------------------------------ + +sub comment_block { + my @return = ( + Fcm::CfgLine->new (comment => $COMMENT_RULER), + (map {Fcm::CfgLine->new (comment => $_)} @_), + Fcm::CfgLine->new (comment => $COMMENT_RULER), + Fcm::CfgLine->new (), + ); + + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::CfgLine->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CfgLine class. See above +# for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + $self->{$_} = $args{$_} if exists $args{$_}; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + if (@_) { + $self->{$name} = $_[0]; + + if ($name eq 'line' or $name eq 'label') { + $self->{slabel} = undef; + + } elsif ($name eq 'line' or $name eq 'value') { + $self->{bvalue} = undef; + } + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name =~ /^(?:comment|error|label|line|prefix|src|value)$/) { + # Blank + $self->{$name} = ''; + + } elsif ($name eq 'slabel') { + if ($self->prefix and $self->label_starts_with ($self->prefix)) { + $self->{$name} = $self->label_from_field (1); + + } else { + $self->{$name} = $self->label; + } + + } elsif ($name eq 'bvalue') { + if (defined ($self->value)) { + $self->{$name} = ($self->value =~ /^(\s*|false|no|off|0*)$/i) + ? 0 : $self->value; + } + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @fields = $obj->label_fields (); +# @fields = $obj->slabel_fields (); +# +# DESCRIPTION +# These method returns a list of fields in the (s)label. +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_fields'; + *$sub_name = sub { + return (split (/$Fcm::Config::DELIMITER_PATTERN/, $_[0]->$name)); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->label_from_field ($index); +# $string = $obj->slabel_from_field ($index); +# +# DESCRIPTION +# These method returns the (s)label from field $index onwards. +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_from_field'; + *$sub_name = sub { + my ($self, $index) = @_; + my $method = $name . '_fields'; + my @fields = $self->$method; + return join ($Fcm::Config::DELIMITER, @fields[$index .. $#fields]); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->label_starts_with (@fields); +# $flag = $obj->slabel_starts_with (@fields); +# +# DESCRIPTION +# These method returns a true if (s)label starts with the labels in @fields +# (ignore case). +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_starts_with'; + *$sub_name = sub { + my ($self, @fields) = @_; + my $return = 1; + + my $method = $name . '_fields'; + my @all_fields = $self->$method; + + for my $i (0 .. $#fields) { + next if lc ($fields[$i]) eq lc ($all_fields[$i] || ''); + $return = 0; + last; + } + + return $return; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->label_starts_with_cfg (@fields); +# $flag = $obj->slabel_starts_with_cfg (@fields); +# +# DESCRIPTION +# These method returns a true if (s)label starts with the configuration file +# labels in @fields (ignore case). +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_starts_with_cfg'; + *$sub_name = sub { + my ($self, @fields) = @_; + + for my $field (@fields) { + $field = $self->cfglabel ($field); + } + + my $method = $name . '_starts_with'; + return $self->$method (@fields); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $mesg = $obj->format_error (); +# +# DESCRIPTION +# This method returns a string containing a formatted error message for +# anything reported to the current line. +# ------------------------------------------------------------------------------ + +sub format_error { + my ($self) = @_; + my $mesg = ''; + + $mesg .= $self->format_warning; + + if ($self->error or not $self->parsed) { + $mesg = 'ERROR: ' . $self->src . ': LINE ' . $self->number . ':' . "\n"; + if ($self->error) { + $mesg .= ' ' . $self->error; + + } else { + $mesg .= ' ' . $self->label . ': label not recognised.'; + } + } + + return $mesg; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $mesg = $obj->format_warning (); +# +# DESCRIPTION +# This method returns a string containing a formatted warning message for +# any warning reported to the current line. +# ------------------------------------------------------------------------------ + +sub format_warning { + my ($self) = @_; + my $mesg = ''; + + if ($self->warning) { + $mesg = 'WARNING: ' . $self->src . ': LINE ' . $self->number . ':' . "\n"; + $mesg .= ' ' . $self->warning; + } + + return $mesg; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $line = $obj->print_line ([$space]); +# +# DESCRIPTION +# This method returns a configuration line using $self->label, $self->value +# and $self->comment. The value in $self->line is re-set. If $space is set +# and is a positive integer, it sets the spacing between the label and the +# value in the line. The default is 1. +# ------------------------------------------------------------------------------ + +sub print_line { + my ($self, $space) = @_; + + # Set space between label and value, default to 1 character + $space = 1 unless $space and $space =~ /^[1-9]\d*$/; + + my $line = ''; + + # Add label and value, if label is set + if ($self->label) { + $line .= $self->label . ' ' x $space; + $line .= $self->value if defined $self->value; + } + + # Add comment if necessary + my $comment = $self->comment; + $comment =~ s/^\s*//; + + if ($comment) { + $comment = '# ' . $comment if $comment !~ /^#/; + $line .= ' ' if $line; + $line .= $comment; + } + + return $self->line ($line); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/64/644a24275a442ff3000de7ff5c437b4dc54e50c3.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/64/644a24275a442ff3000de7ff5c437b4dc54e50c3.svn-base new file mode 100644 index 0000000..025b88e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/64/644a24275a442ff3000de7ff5c437b4dc54e50c3.svn-base @@ -0,0 +1,72 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Formatter::Entry::Location; +use base qw{Fcm::Keyword::Formatter::Entry}; + +use Fcm::Config; +use Fcm::Keyword::Formatter::Entries; + +################################################################################ +# Formats a keyword entry +sub format { + my ($self, $entry) = @_; + my $return = $self->SUPER::format($entry); + for my $implied_entry (@{$entry->get_implied_entry_list()}) { + $return .= $self->SUPER::format($implied_entry); + } + if (@{$entry->get_revision_entries()->get_all_entries()}) { + my $formatter = Fcm::Keyword::Formatter::Entries->new(); + $return .= "\n[revision keyword]\n"; + $return .= $formatter->format($entry->get_revision_entries()); + } + return $return; +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Formatter::Entry::Location + +=head1 SYNOPSIS + + use Fcm::Keyword::Formatter::Entry::Location; + $formatter = Fcm::Keyword::Formatter::Entry::Location->new(); + print($formatter->format($entry)); + +=head1 DESCRIPTION + +An object of this class is used to format the detail in a location keyword entry. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item format($entry) + +Returns a string representation of $entry. + +=back + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/64/646571edaafd3f7952b707c71dbe900f6a4fbf2c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/64/646571edaafd3f7952b707c71dbe900f6a4fbf2c.svn-base new file mode 100644 index 0000000..c833f49 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/64/646571edaafd3f7952b707c71dbe900f6a4fbf2c.svn-base @@ -0,0 +1,552 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Util +# +# DESCRIPTION +# This is a package of misc utilities used by the FCM command. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use warnings; +use strict; + +package Fcm::Util; +require Exporter; +our @ISA = qw{Exporter}; + +sub expand_tilde; +sub e_report; +sub find_file_in_path; +sub get_command_string; +sub get_rev_of_wc; +sub get_url_of_wc; +sub get_url_peg_of_wc; +sub get_wct; +sub is_url; +sub is_wc; +sub print_command; +sub run_command; +sub svn_date; +sub tidy_url; +sub touch_file; +sub w_report; + +our @EXPORT = qw{ + expand_tilde + e_report + find_file_in_path + get_command_string + get_rev_of_wc + get_url_of_wc + get_url_peg_of_wc + get_wct + is_url + is_wc + print_command + run_command + svn_date + tidy_url + touch_file + w_report +}; + +# Standard modules +use Carp; +use Cwd; +use File::Basename; +use File::Find; +use File::Path; +use File::Spec; +use POSIX qw{strftime SIGINT SIGKILL SIGTERM WEXITSTATUS WIFSIGNALED WTERMSIG}; + +# FCM component modules +use Fcm::Timer; + +# ------------------------------------------------------------------------------ + +# Module level variables +my %svn_info = (); # "svn info" log, (key1 = path, + # key2 = URL, Revision, Last Changed Rev) + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %srcdir = &Fcm::Util::find_file_in_path ($file, \@path); +# +# DESCRIPTION +# Search $file in @path. Returns the full path of the $file if it is found +# in @path. Returns "undef" if $file is not found in @path. +# ------------------------------------------------------------------------------ + +sub find_file_in_path { + my ($file, $path) = @_; + + for my $dir (@$path) { + my $full_file = File::Spec->catfile ($dir, $file); + return $full_file if -e $full_file; + } + + return undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $expanded_path = &Fcm::Util::expand_tilde ($path); +# +# DESCRIPTION +# Returns an expanded path if $path is a path that begins with a tilde (~). +# ------------------------------------------------------------------------------ + +sub expand_tilde { + my $file = $_[0]; + + $file =~ s#^~([^/]*)#$1 ? (getpwnam $1)[7] : ($ENV{HOME} || $ENV{LOGDIR})#ex; + + # Expand . and .. + while ($file =~ s#/+\.(?:/+|$)#/#g) {next} + while ($file =~ s#/+[^/]+/+\.\.(?:/+|$)#/#g) {next} + + # Remove trailing / + $file =~ s#/*$##; + + return $file; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &Fcm::Util::touch_file ($file); +# +# DESCRIPTION +# Touch $file if it exists. Create $file if it does not exist. Return 1 for +# success or 0 otherwise. +# ------------------------------------------------------------------------------ + +sub touch_file { + my $file = $_[0]; + my $rc = 1; + + if (-e $file) { + my $now = time; + $rc = utime $now, $now, $file; + + } else { + mkpath dirname ($file) unless -d dirname ($file); + + $rc = open FILE, '>', $file; + $rc = close FILE if $rc; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = &is_wc ([$path]); +# +# DESCRIPTION +# Returns true if current working directory (or $path) is a Subversion +# working copy. +# ------------------------------------------------------------------------------ + +sub is_wc { + my $path = @_ ? $_[0] : cwd (); + + if (-d $path) { + return (-e File::Spec->catfile ($path, qw/.svn format/)) ? 1 : 0; + + } elsif (-f $path) { + return (-e File::Spec->catfile (dirname ($path), qw/.svn format/)) ? 1 : 0; + + } else { + return 0; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = &is_url ($url); +# +# DESCRIPTION +# Returns true if $url is a URL. +# ------------------------------------------------------------------------------ + +sub is_url { + # This should handle URL beginning with svn://, http:// and svn+ssh:// + return ($_[0] =~ m#^[\+\w]+://#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = tidy_url($url); +# +# DESCRIPTION +# Returns a tidied version of $url by removing . and .. in the path. +# ------------------------------------------------------------------------------ + +sub tidy_url { + my ($url) = @_; + if (!is_url($url)) { + return $url; + } + my $DOT_PATTERN = qr{/+ \. (?:/+|(@|\z))}xms; + my $DOT_DOT_PATTERN = qr{/+ [^/]+ /+ \.\. (?:/+|(@|\z))}xms; + my $TRAILING_SLASH_PATTERN = qr{([^/]+) /* (@|\z)}xms; + my $RIGHT_EVAL = q{'/' . ($1 ? $1 : '')}; + DOT: + while ($url =~ s{$DOT_PATTERN}{$RIGHT_EVAL}eegxms) { + next DOT; + } + DOT_DOT: + while ($url =~ s{$DOT_DOT_PATTERN}{$RIGHT_EVAL}eegxms) { + next DOT_DOT; + } + $url =~ s{$TRAILING_SLASH_PATTERN}{$1$2}xms; + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_wct ([$dir]); +# +# DESCRIPTION +# If current working directory (or $dir) is a Subversion working copy, +# returns the top directory of this working copy; otherwise returns an empty +# string. +# ------------------------------------------------------------------------------ + +sub get_wct { + my $dir = @_ ? $_[0] : cwd (); + + return '' if not &is_wc ($dir); + + my $updir = dirname $dir; + while (&is_wc ($updir)) { + $dir = $updir; + $updir = dirname $dir; + last if $updir eq $dir; + } + + return $dir; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_url_of_wc ([$path[, $refresh]]); +# +# DESCRIPTION +# If current working directory (or $path) is a Subversion working copy, +# returns the URL of the associated Subversion repository; otherwise returns +# an empty string. If $refresh is specified, do not use the cached +# information. +# ------------------------------------------------------------------------------ + +sub get_url_of_wc { + my $path = @_ ? $_[0] : cwd (); + my $refresh = exists $_[1] ? $_[1] : 0; + my $url = ''; + + if (&is_wc ($path)) { + delete $svn_info{$path} if $refresh; + &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; + $url = $svn_info{$path}{URL}; + } + + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_url_peg_of_wc ([$path[, $refresh]]); +# +# DESCRIPTION +# If current working directory (or $path) is a Subversion working copy, +# returns the URL@REV of the associated Subversion repository; otherwise +# returns an empty string. If $refresh is specified, do not use the cached +# information. +# ------------------------------------------------------------------------------ + +sub get_url_peg_of_wc { + my $path = @_ ? $_[0] : cwd (); + my $refresh = exists $_[1] ? $_[1] : 0; + my $url = ''; + + if (&is_wc ($path)) { + delete $svn_info{$path} if $refresh; + &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; + $url = $svn_info{$path}{URL} . '@' . $svn_info{$path}{Revision}; + } + + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &_invoke_svn_info (PATH => $path); +# +# DESCRIPTION +# The function is internal to this module. It invokes "svn info" on $path to +# gather information on URL, Revision and Last Changed Rev. The information +# is stored in a hash table at the module level, so that the information can +# be re-used. +# ------------------------------------------------------------------------------ + +sub _invoke_svn_info { + my %args = @_; + my $path = $args{PATH}; + my $cfg = Fcm::Config->instance(); + + return if exists $svn_info{$path}; + + # Invoke "svn info" command + my @info = &run_command ( + [qw/svn info/, $path], + PRINT => $cfg->verbose > 2, METHOD => 'qx', DEVNULL => 1, ERROR => 'ignore', + ); + for (@info) { + chomp; + + if (/^(URL|Revision|Last Changed Rev):\s*(.+)$/) { + $svn_info{$path}{$1} = $2; + } + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_command_string ($cmd); +# $string = &get_command_string (\@cmd); +# +# DESCRIPTION +# The function returns a string by converting the list in @cmd or the scalar +# $cmd to a form, where it can be executed as a shell command. +# ------------------------------------------------------------------------------ + +sub get_command_string { + my $cmd = $_[0]; + my $return = ''; + + if (ref ($cmd) and ref ($cmd) eq 'ARRAY') { + # $cmd is a reference to an array + + # Print each argument + for my $i (0 .. @{ $cmd } - 1) { + my $arg = $cmd->[$i]; + + $arg =~ s/./*/g if $i > 0 and $cmd->[$i - 1] eq '--password'; + + if ($arg =~ /[\s'"*?]/) { + # Argument contains a space, quote it + if (index ($arg, "'") >= 0) { + # Argument contains an apostrophe, quote it with double quotes + $return .= ($i > 0 ? ' ' : '') . '"' . $arg . '"'; + + } else { + # Otherwise, quote argument with apostrophes + $return .= ($i > 0 ? ' ' : '') . "'" . $arg . "'"; + } + + } else { + # Argument does not contain a space, just print it + $return .= ($i > 0 ? ' ' : '') . ($arg eq '' ? "''" : $arg); + } + } + + } else { + # $cmd is a scalar, just print it "as is" + $return = $cmd; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &print_command ($cmd); +# &print_command (\@cmd); +# +# DESCRIPTION +# The function prints the list in @cmd or the scalar $cmd, as it would be +# executed by the shell. +# ------------------------------------------------------------------------------ + +sub print_command { + my $cmd = $_[0]; + + print '=> ', &get_command_string ($cmd) , "\n"; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @return = &run_command (\@cmd, ); +# @return = &run_command ($cmd , ); +# +# DESCRIPTION +# This function executes the command in the list @cmd or in the scalar $cmd. +# The remaining are optional arguments in a hash table. Valid options are +# listed below. If the command is run using "qx", the function returns the +# standard output from the command. If the command is run using "system", the +# function returns true on success. By default, the function dies on failure. +# +# OPTIONS +# METHOD => $method - this can be "system", "exec" or "qx". This determines +# how the command will be executed. If not set, the +# default is to run the command with "system". +# PRINT => 1 - if set, print the command before executing it. +# ERROR => $flag - this should only be set if METHOD is set to "system" +# or "qx". The $flag can be "die" (default), "warn" or +# "ignore". If set to "die", the function dies on error. +# If set to "warn", the function issues a warning on +# error, and the function returns false. If set to +# "ignore", the function returns false on error. +# RC => 1 - if set, must be a reference to a scalar, which will be +# set to the return code of the command. +# DEVNULL => 1 - if set, re-direct STDERR to /dev/null before running +# the command. +# TIME => 1 - if set, print the command with a timestamp before +# executing it, and print the time taken when it +# completes. This option supersedes the PRINT option. +# ------------------------------------------------------------------------------ + +sub run_command { + my ($cmd, %input_opt_of) = @_; + my %opt_of = ( + DEVNULL => undef, + ERROR => 'die', + METHOD => 'system', + PRINT => undef, + RC => undef, + TIME => undef, + %input_opt_of, + ); + local($|) = 1; # Make sure STDOUT is flushed before running command + + # Print the command before execution, if necessary + if ($opt_of{TIME}) { + print(timestamp_command(get_command_string($cmd))); + } + elsif ($opt_of{PRINT}) { + print_command($cmd); + } + + # Re-direct STDERR to /dev/null if necessary + if ($opt_of{DEVNULL}) { + no warnings; + open(OLDERR, ">&STDERR") || croak("Cannot dup STDERR ($!), abort"); + use warnings; + open(STDERR, '>', File::Spec->devnull()) + || croak("Cannot redirect STDERR ($!), abort"); + # Make sure the channels are unbuffered + my $select = select(); + select(STDERR); local($|) = 1; + select($select); + } + + my @return = (); + if (ref($cmd) && ref($cmd) eq 'ARRAY') { + # $cmd is an array + my @command = @{$cmd}; + if ($opt_of{METHOD} eq 'qx') { + @return = qx(@command); + } + elsif ($opt_of{METHOD} eq 'exec') { + exec(@command); + } + else { + system(@command); + @return = $? ? () : (1); + } + } + else { + # $cmd is an scalar + if ($opt_of{METHOD} eq 'qx') { + @return = qx($cmd); + } + elsif ($opt_of{METHOD} eq 'exec') { + exec($cmd); + } + else { + system($cmd); + @return = $? ? () : (1); + } + } + my $rc = $?; + + # Put STDERR back to normal, if redirected previously + if ($opt_of{DEVNULL}) { + close(STDERR); + open(STDERR, ">&OLDERR") || croak("Cannot dup STDERR ($!), abort"); + } + + # Print the time taken for command after execution, if necessary + if ($opt_of{TIME}) { + print(timestamp_command(get_command_string($cmd), 'end')); + } + + # Signal and return code + my ($signal, $status) = (WTERMSIG($rc), WEXITSTATUS($rc)); + if (exists($opt_of{RC})) { + ${$opt_of{RC}} = $status; + } + if (WIFSIGNALED($rc) && grep {$signal == $_} (SIGINT, SIGKILL, SIGTERM)) { + croak(sprintf('%s terminated (%d)', get_command_string($cmd), $signal)); + } + if ($status && $opt_of{ERROR} ne 'ignore') { + my $func_ref = $opt_of{ERROR} eq 'warn' ? \&carp : \&croak; + $func_ref->(sprintf('%s failed (%d)', get_command_string($cmd), $status)); + } + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &e_report (@message); +# +# DESCRIPTION +# The function prints @message to STDERR and aborts with a error. +# ------------------------------------------------------------------------------ + +sub e_report { + print STDERR @_, "\n" if @_; + + exit 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &w_report (@message); +# +# DESCRIPTION +# The function prints @message to STDERR and returns. +# ------------------------------------------------------------------------------ + +sub w_report { + print STDERR @_, "\n" if @_; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $date = &svn_date ($time); +# +# DESCRIPTION +# The function returns a date, formatted as by Subversion. The argument $time +# is the number of seconds since epoch. +# ------------------------------------------------------------------------------ + +sub svn_date { + my $time = shift; + + return strftime ('%Y-%m-%d %H:%M:%S %z (%a, %d %b %Y)', localtime ($time)); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/66/6641a6bfe4a787b2a7503d6a7280368f00a7241b.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/66/6641a6bfe4a787b2a7503d6a7280368f00a7241b.svn-base new file mode 100644 index 0000000..e9b92fa --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/66/6641a6bfe4a787b2a7503d6a7280368f00a7241b.svn-base @@ -0,0 +1,87 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ExtractSrc +# +# DESCRIPTION +# This class is used by the extract system to define the functionalities of a +# source file (or directory) in a branch. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::ExtractSrc; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# FCM component modules +use Fcm::Base; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'cache', # location of the cache of this file in the current extract + 'id', # short ID of the branch where this file is from + 'ignore', # if set to true, ignore this file from this source + 'pkgname', # package name of this file + 'rev', # last changed revision/timestamp of this file + 'uri', # URL/source path of this file +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ExtractSrc->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ExtractSrc class. See +# @scalar_properties above for allowed list of properties in the constructor. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{$_} ? $args{$_} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/67/675f1dce40784d191da4c279e0df463d20c0af90.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/67/675f1dce40784d191da4c279e0df463d20c0af90.svn-base new file mode 100644 index 0000000..c9b0470 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/67/675f1dce40784d191da4c279e0df463d20c0af90.svn-base @@ -0,0 +1,80 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Util::ClassLoader; +use base qw{Exporter}; + +our @EXPORT_OK = qw{load}; + +use Carp qw{croak}; +use Fcm::Exception; + +sub load { + my ($class, $test_method) = @_; + if (!$test_method) { + $test_method = 'new'; + } + if (!UNIVERSAL::can($class, $test_method)) { + eval('require ' . $class); + if ($@) { + croak(Fcm::Exception->new({message => sprintf( + "%s: class loading failed: %s", $class, $@, + )})); + } + } + return $class; +} + +1; +__END__ + +=head1 NAME + +Fcm::ClassLoader + +=head1 SYNOPSIS + + use Fcm::Util::ClassLoader; + $load_ok = Fcm::Util::ClassLoader::load($class); + +=head1 DESCRIPTION + +A wrapper for loading a class dynamically. + +=head1 FUNCTIONS + +=over 4 + +=item load($class,$test_method) + +If $class can call $test_method, returns $class. Otherwise, attempts to +require() $class and returns it. If this fails, croak() with a +L. + +=item load($class) + +Shorthand for C. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The load($class,$test_method) function croak() with this exception if it fails +to load the specified class. + +=back + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/6a/6a127f9a9c80d0647ff3f4e22edf57fd9b860788.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/6a/6a127f9a9c80d0647ff3f4e22edf57fd9b860788.svn-base new file mode 100644 index 0000000..3fd77b7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/6a/6a127f9a9c80d0647ff3f4e22edf57fd9b860788.svn-base @@ -0,0 +1,122 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive::InputGetter; + +use Carp qw{croak}; + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + ############################################################################ + # Returns the title of the prompt + 'title', + ############################################################################ + # Returns the message of the prompt + 'message', + ############################################################################ + # Returns the of the prompt + 'type', + ############################################################################ + # Returns the default return value + 'default', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + return $self->{$key}; + } +} + +################################################################################ +# Invokes the getter +sub invoke { + my ($self) = @_; + croak("Fcm::Interactive::InputGetter->invoke() not implemented."); +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive::TxtInputGetter + +=head1 SYNOPSIS + + use Fcm::Interactive::TxtInputGetter; + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +An object of this abstract class is used by +L to get a user reply. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor, normally invoked via L. + +Input options are: I, for a short title of the prompt, I<message>, for +the message prompt, I<type> for the prompt type, and I<default> for the default +value of the return value. + +Prompt type can be YN (yes or no), YNA (yes, no or all) or input (for an input +string). + +=item get_title() + +Returns the title of the prompt. + +=item get_message() + +Returns the message of the prompt. + +=item get_type() + +Returns the type of the prompt, can be YN (yes or no), YNA (yes, no or all) or +input (for an input string). + +=item get_default() + +Returns the default return value of invoke(). + +=item invoke() + +Gets an input string from the user, and returns it. Sub-classes must override +this method. + +=back + +=head1 SEE ALSO + +L<Fcm::Interactive|Fcm::Interactive>, +L<Fcm::Interactive::TxtInputGetter|Fcm::Interactive::TxtInputGetter>, +L<Fcm::Interactive::GUIInputGetter|Fcm::Interactive::GUIInputGetter> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/731aa54486da81b6e9be95ce85c0c7efe52f2b24.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/731aa54486da81b6e9be95ce85c0c7efe52f2b24.svn-base new file mode 100644 index 0000000..d11984b --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/731aa54486da81b6e9be95ce85c0c7efe52f2b24.svn-base @@ -0,0 +1,173 @@ +=head1 NAME + +fcm branch (br) + +=head1 SYNOPSIS + +Create, delete or display information of a branch, or list branches in a +project. + + fcm branch [--info] [OPTIONS] [TARGET] + fcm branch --delete [OPTIONS] [TARGET] + fcm branch --create [OPTIONS] [SOURCE] + fcm branch --list [OPTIONS] [SOURCE] + +=head1 ARGUMENTS + +TARGET (and SOURCE) can be an URL or a Subversion working copy. Otherwise, +the current working directory must be a working copy. For --info and +--delete, the specified URL (or the URL of the working copy) must be a URL +under a valid branch in a standard FCM project. For --create and --list, it +must be a URL under a standard FCM project. + +=head1 OPTIONS + +=over 4 + +=item --info or -i + +Display information about a branch. This is the default option if --create, +--delete and --list are not specified. + +=item --delete or -d + +Delete a branch. + +=item --create or -c + +Create a new branch from SOURCE. The --name option must be used to specify a +short name for the new branch. + +=item --list or -l + +List all the branches owned by the current user in SOURCE. If the --user option +is specified with a list of users, list all the branches owned by these users +instead of the current user. + +=back + +Valid options with --info and --delete: + +=over 4 + +=item -v [--verbose] + +Print extra information. + +=item -a [--show-all] + +Set --show-children, --show-other and --show-siblings. + +=item --show-children + +Report children of the current branch. + +=item --show-other + +Report custom/ reverse merges into the current branch. + +=item --show-siblings + +Report merges with siblings of the current branch. + +=back + +Valid options with --delete and --create: + +=over 4 + +=item --non-interactive + +Do no interactive prompting. This option implies --svn-non-interactive. + +=item --password arg + +Specify a password for write access to the repository. + +=item --svn-non-interactive + +Do no interactive prompting at commit time. This option is implied by +--non-interactive. + +=back + +Valid options with --create and --list: + +=over 4 + +=item -r [--revision] arg + +Specify the operative revision of the SOURCE for creating the branch. + +=back + +Valid options with --create: + +=over 4 + +=item --branch-of-branch + +If this option is specified and the SOURCE is a branch, it will create a new +branch from the SOURCE branch. Otherwise, the branch is created from the trunk. + +=item -k [--ticket] arg + +Specify one (or more) Trac ticket. If specified, the command will add to the +commit log the line "Relates to ticket #<ticket>". Multiple tickets can be set +by specifying this option multiple times, or by specifying the tickets in a +comma-separated list. + +=item -n [--name] arg + +Specify a short name for the branch, which should contain only characters in the +set [A-Za-z0-9_-.]. + +=item --rev-flag arg + +Specify a flag for determining the prefix of the branch name. The flag can be +the the string "NORMAL", "NUMBER" or "NONE". "NORMAL" is the default behaviour, +in which the branch name will be prefixed with a Subversion revision number if +the revision is not associated with a registered FCM revision keyword. If the +revision is registered with a FCM revision keyword, the keyword will be used in +place of the number. If "NUMBER" is specified, the branch name will always be +prefixed with a Subversion revision number. If "NONE" is specified, the branch +name will not be prefixed by a revision number or keyword. + +=item -t [--type] arg + +Specify the type of the branch to be created. It must be one of the following: + + DEV::USER [DEV, USER] - a development branch for the user + DEV::SHARE [SHARE] - a shared development branch + TEST::USER [TEST] - a test branch for the user + TEST::SHARE - a shared test branch + PKG::USER [PKG] - a package branch for the user + PKG::SHARE - a shared package branch + PKG::CONFIG [CONFIG] - a configuration branch + PKG::REL [REL] - a release branch + +If not specified, the default is to create a development branch for the current +user, i.e. DEV::USER. + +=back + +Valid options with --list: + +=over 4 + +=item -a [--show-all] + +Print all branches. + +=item -u [--user] arg + +Specify a colon-separated list of users. List branches owned by these users +instead of the current user. + +=item -v [--verbose] + +Print Subversion URL instead of FCM URL keywords. + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/7386b473a4c0d47f167d2978e23dbacc05ebf33b.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/7386b473a4c0d47f167d2978e23dbacc05ebf33b.svn-base new file mode 100644 index 0000000..55bd30c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/7386b473a4c0d47f167d2978e23dbacc05ebf33b.svn-base @@ -0,0 +1,2721 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Cm +# +# DESCRIPTION +# This module contains the FCM code management functionalities and wrappers +# to Subversion commands. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Cm; +use base qw{Exporter}; + +our @EXPORT_OK = qw(cli cm_check_missing cm_check_unknown cm_switch cm_update); + +use Cwd qw{cwd}; +use Getopt::Long qw{GetOptions :config bundling}; +use Fcm::CLI::Exception; +use Fcm::Config; +use Fcm::CmBranch; +use Fcm::CmUrl; +use Fcm::Keyword; +use Fcm::Util qw{ + get_url_of_wc + get_url_peg_of_wc + get_wct + is_url + is_wc + run_command + tidy_url +}; +use File::Basename qw{basename dirname}; +use File::Path qw{mkpath rmtree}; +use File::Spec; +use File::Temp qw{tempfile}; +use Pod::Usage qw{pod2usage}; + +# ------------------------------------------------------------------------------ + +# CLI message handler +our $CLI_MESSAGE = \&_cli_message; + +# List of CLI messages +our %CLI_MESSAGE_FOR = ( + q{} => "%s", + BRANCH_LIST => "%s at %s: %d branch(es) found for %s.\n", + CHDIR_WCT => "%s: working directory changed to top of working copy.\n", + CF => "Conflicts in: %s\n", + MERGE => "Performing merge ...\n", + MERGE_CF => "About to merge in changes from %s compared with %s\n", + MERGE_CI => "The following is added to the commit message file:\n%s", + MERGE_DRY => "This merge will result in the following change:\n", + MERGE_REVS => "Merge(s) available from %s: %s\n", + OUT_DIR => "Output directory: %s\n", + PATCH_DONE => "%s: patch generated.\n", + PATCH_REV => "Patch created for changeset %s\n", + SEPARATOR => q{-} x 80 . "\n", + STATUS => "Status of the target working copy(ies):\n%s", +); + +# CLI abort and error messages +our %CLI_MESSAGE_FOR_ABORT = ( + FAIL => "%s: command failed.\n", + NULL => "%s: command will result in no change.\n", + USER => "%s: abort by user.\n", +); + +# CLI abort and error messages +our %CLI_MESSAGE_FOR_ERROR = ( + CHDIR => "%s: cannot change to directory.\n", + CLI => "%s", + CLI_HELP => "Type 'fcm help %s' for usage.\n", + CLI_MERGE_ARG1 => "Arg 1 must be the source in auto/custom mode.\n", + CLI_MERGE_ARG2 => "Arg 2 must be the source in custom mode" + . " if --revision not set.\n", + CLI_OPT_ARG => "--%s: invalid argument [%s].\n", + CLI_OPT_WITH_OPT => "--%s: must be specified with --%s.\n", + CLI_USAGE => "incorrect usage", + DIFF_PROJECTS => "%s (target) and %s (source) are not related.\n", + INVALID_BRANCH => "%s: not a valid URL of a standard FCM branch.\n", + INVALID_PROJECT => "%s: not a valid URL of a standard FCM project.\n", + INVALID_TARGET => "%s: not a valid working copy or URL.\n", + INVALID_URL => "%s: not a valid URL.\n", + INVALID_WC => "%s: not a valid working copy.\n", + MERGE_REV_INVALID => "%s: not a revision in the available merge list.\n", + MERGE_SELF => "%s: cannot be merged to its own working copy: %s.\n", + MERGE_UNRELATED => "%s: target and %s: source not directly related.\n", + MERGE_UNSAFE => "%s: source contains changes outside the target" + . " sub-directory. Please merge with a full tree.\n", + MKPATH => "%s: cannot create directory.\n", + NOT_EXIST => "%s: does not exist.\n", + PARENT_NOT_EXIST => "%s: parent %s no longer exists.\n", + RMTREE => "%s: cannot remove.\n", + ST_CONFLICT => "File(s) in conflicts:\n%s", + ST_MISSING => "File(s) missing:\n%s", + ST_OUT_OF_DATE => "File(s) out of date:\n%s", + SWITCH_UNSAFE => "%s: merge template exists." + . " Please remove before retrying.\n", + WC_EXIST => "%s: working copy already exists.\n", + WC_INVALID_BRANCH => "%s: not a working copy of a standard FCM branch.\n", + WC_URL_NOT_EXIST => "%s: working copy URL does not exists at HEAD.\n", +); + +# List of CLI prompt messages +our %CLI_MESSAGE_FOR_PROMPT = ( + CF_OVERWRITE => qq{%s: existing changes will be overwritten.\n} + . qq{ Do you wish to continue?}, + CI => qq{Would you like to commit this change?}, + CI_BRANCH_SHARED => qq{\n} + . qq{*** WARNING: YOU ARE COMMITTING TO A %s BRANCH.\n} + . qq{*** Please ensure that you have the} + . qq{ owner's permission.\n\n} + . qq{Would you like to commit this change?}, + CI_BRANCH_USER => qq{\n} + . qq{*** WARNING: YOU ARE COMMITTING TO A BRANCH} + . qq{ NOT OWNED BY YOU.\n} + . qq{*** Please ensure that you have the} + . qq{ owner's permission.\n\n} + . qq{Would you like to commit this change?}, + CI_TRUNK => qq{\n} + . qq{*** WARNING: YOU ARE COMMITTING TO THE TRUNK.\n} + . qq{*** Please ensure that your change conforms to} + . qq{ your project's working practices.\n\n} + . qq{Would you like to commit this change?}, + CONTINUE => qq{Are you sure you want to continue?}, + MERGE => qq{Would you like to go ahead with the merge?}, + MERGE_REV => qq{Please enter the revision you wish to merge from}, + MKPATCH_OVERWRITE => qq{%s: output location exists. OK to overwrite?}, + RUN_SVN_COMMAND => qq{Would you like to run "svn %s"?}, +); + +# List of CLI warning messages +our %CLI_MESSAGE_FOR_WARNING = ( + BRANCH_SUBDIR => "%s: is a sub-directory of a branch in a FCM project.\n", + CF_BINARY => "%s: ignoring binary file, please resolve manually.\n", + INVALID_BRANCH => $CLI_MESSAGE_FOR_ERROR{INVALID_BRANCH}, + ST_IN_TRAC_DIFF => "%s: local changes cannot be displayed in Trac.\n" +); + +# CLI prompt handler and title prefix +our $CLI_PROMPT = \&_cli_prompt; +our $CLI_PROMPT_PREFIX = q{fcm }; + +# List of exception handlers [$class, CODE->($function, $e)] +our @CLI_EXCEPTION_HANDLERS = ( + ['Fcm::CLI::Exception', \&_cli_e_handler_of_cli_exception], + ['Fcm::Cm::Exception' , \&_cli_e_handler_of_cm_exception], + ['Fcm::Cm::Abort' , \&_cli_e_handler_of_cm_abort], +); + +# Event handlers +our %CLI_HANDLER_OF = ( + 'WC_STATUS' => \&_cli_handler_of_wc_status, + 'WC_STATUS_PATH' => \&_cli_handler_of_wc_status_path, +); + +# Handlers of sub-commands +our %CLI_IMPL_OF = ( + 'add' => \&_cli_command_add, + 'branch' => \&cm_branch, + 'commit' => \&cm_commit, + 'conflicts' => \&cm_conflicts, + 'checkout' => \&_cli_command_checkout, + 'delete' => \&_cli_command_delete, + 'diff' => \&cm_diff, + 'merge' => \&cm_merge, + 'mkpatch' => \&cm_mkpatch, + 'switch' => \&_cli_command_switch, + 'update' => \&_cli_command_update, +); + +# List of overridden subcommands that need to display "svn help" +our %CLI_MORE_HELP_FOR = map {($_, 1)} qw{add diff delete switch update}; + +# The preferred name of subcommand aliases +our %CLI_PREFERRED_NAME_OF = ( + 'ann' => 'blame', + 'annotate' => 'blame', + 'br' => 'branch', + 'ci' => 'commit', + 'cf' => 'conflicts', + 'co' => 'checkout', + 'cp' => 'copy', + 'del' => 'delete', + 'di' => 'diff', + 'ls' => 'list', + 'mv' => 'move', + 'pd' => 'propdel', + 'pdel' => 'propdel', + 'pe' => 'propedit', + 'pedit' => 'propedit', + 'pg' => 'propget', + 'pget' => 'propget', + 'pl' => 'proplist', + 'plist' => 'proplist', + 'praise' => 'blame', + 'ps' => 'propset', + 'pset' => 'propset', + 'remove' => 'delete', + 'ren' => 'move', + 'rename' => 'move', + 'rm' => 'delete', + 'sw' => 'switch', + 'up' => 'update', +); + +# List of subcommands that accept URL inputs +our %CLI_SUBCOMMAND_URL = map {($_, 1)} qw{ + blame + branch + cat + checkout + copy + delete + diff + export + import + info + list + lock + log + merge + mkdir + mkpatch + move + propdel + propedit + propget + proplist + propset + switch + unlock +}; + +# List of subcommands that accept revision inputs +our %CLI_SUBCOMMAND_REV = map {($_, 1)} qw{ + blame + branch + cat + checkout + copy + diff + export + info + list + log + merge + mkpatch + move + propdel + propedit + propget + proplist + propset + switch +}; + +# Common patterns +our %PATTERN_OF = ( + # A CLI option + CLI_OPT => qr{ + \A (?# beginning) + (--\w[\w-]*=) (?# capture 1, a long option label) + (.*) (?# capture 2, the value of the option) + \z (?# end) + }xms, + # A CLI revision option + CLI_OPT_REV => qr{ + \A (?# beginning) + (--revision(?:=|\z)|-r) (?# capture 1, --revision, --revision= or -r) + (.*) (?# capture 2, trailing value) + \z (?# end) + }xms, + # A CLI revision option range + CLI_OPT_REV_RANGE => qr{ + \A (?# beginning) + ( (?# capture 1, begin) + (?:\{[^\}]+\}+) (?# a date in curly braces) + | (?# or) + [^:]+ (?# anything but a colon) + ) (?# capture 1, end) + (?::(.*))? (?# colon, and capture 2 til the end) + \z (?# end) + }xms, + # A FCM branch path look-alike, should be configurable in the future + FCM_BRANCH_PATH => qr{ + \A (?# beginning) + /* (?# some slashes) + (?: (?# group 1, begin) + (?:trunk/*(?:@\d+)?\z) (?# trunk at a revision) + | (?# or) + (?:trunk|branches|tags)/+ (?# trunk, branch or tags) + ) (?# group 1, end) + }xms, + # Last line of output from "svn status -u" + ST_AGAINST_REV => qr{ + \A (?# beginning) + Status\sagainst\srevision:.* (?# output of svn status -u) + \z (?# end) + }xms, + # Extract path from "svn status" + ST_PATH => qr{ + \A (?# beginning) + .{6} (?# 6 columns) + \s+ (?# spaces) + (.+) (?# capture 1, target path) + \z (?# end) + }xms, + # A legitimate "svn" revision + SVN_REV => qr{ + \A (?# beginning) + (?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}) (?# digit, reserved words, date) + \z (?# end) + }ixms, +); + +# Status matchers +our %ST_MATCHER_FOR = ( + MISSING => sub {substr($_[0], 0, 1) eq '!'}, + MODIFIED => sub {substr($_[0], 0, 6) =~ qr{\S}xms}, + OUT_OF_DATE => sub {substr($_[0], 7, 1) eq '*'}, + UNKNOWN => sub {substr($_[0], 0, 1) eq '?'}, +); + +# ------------------------------------------------------------------------------ +# Entry function for the FCM code management CLI. Calls the relevant FCM code +# management function or SVN command based on $function. +sub cli { + my ($function, @args) = @_; + if (exists($CLI_PREFERRED_NAME_OF{$function})) { + $function = $CLI_PREFERRED_NAME_OF{$function}; + } + if (grep {$_ eq '-h' || $_ eq '--help'} @args) { + return _cli_help($function, 'NOEXIT'); + } + if (exists($CLI_SUBCOMMAND_URL{$function})) { + _cli_keyword_expand_url(\@args); + } + if (exists($CLI_SUBCOMMAND_REV{$function})) { + _cli_keyword_expand_rev(\@args); + } + if (exists($CLI_IMPL_OF{$function})) { + eval { + local(@ARGV) = @args; + return $CLI_IMPL_OF{$function}->(@args); + }; + if ($@) { + my $e = $@; + for (@CLI_EXCEPTION_HANDLERS) { + my ($class, $handler) = @{$_}; + if ($class->caught($e)) { + return $handler->($function, $e); + } + } + die($e); + } + } + else { + return _svn($function, @args); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_branch (); +# +# DESCRIPTION +# This is a FCM command to check information, create or delete a branch in +# a Subversion repository. +# ------------------------------------------------------------------------------ + +sub cm_branch { + # Process command line options + # ---------------------------------------------------------------------------- + my ( + $info, + $delete, + $create, + $list, + $branch_of_branch, + $name, + $non_interactive, + $password, + $rev, + $rev_flag, + $show_all, + $show_children, + $show_other, + $show_siblings, + $svn_non_interactive, + @tickets, + $type, + @userlist, + $verbose, + ); + my $rc = GetOptions( + 'info|i' => \$info, + 'delete|d' => \$delete, + 'create|c' => \$create, + 'list|l' => \$list, + 'branch-of-branch' => \$branch_of_branch, + 'name|n=s' => \$name, + 'non-interactive' => \$non_interactive, + 'password=s' => \$password, + 'revision|r=s' => \$rev, + 'rev-flag=s' => \$rev_flag, + 'show-all|a' => \$show_all, + 'show-children' => \$show_children, + 'show-other' => \$show_other, + 'show-siblings' => \$show_siblings, + 'svn-non-interactive' => \$svn_non_interactive, + 'ticket|k=s' => \@tickets, + 'type|t=s' => \$type, + 'user|u=s' => \@userlist, + 'verbose|v' => \$verbose, + ); + if (!$rc) { + _cli_err(); + } + + my $num_options = 0; + $num_options++ if defined $info; + $num_options++ if defined $delete; + $num_options++ if defined $create; + $num_options++ if defined $list; + if ($num_options > 1) { + _cli_err(); + } + + # Get URL of repository or branch + # ---------------------------------------------------------------------------- + my $url; + if ($ARGV[0]) { + $url = Fcm::CmUrl->new (URL => $ARGV[0]); + + if (not $url->is_url) { + # An argument is specified and is not a URL + # Assume that it is a path with a working copy + if (&is_wc ($ARGV[0])) { + $url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0])); + + } else { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $ARGV[0]); + } + } + + } else { + # An argument is not specified + # Assume that the current directory is a working copy + if (&is_wc ()) { + $url = Fcm::CmUrl->new (URL => &get_url_of_wc ()); + + } else { + return _cm_err(Fcm::Cm::Exception->INVALID_TARGET, '.'); + } + } + + # Ensure $url->url_peg is a URL of a standard FCM project + if (!$url->project_url()) { + return _cm_err(Fcm::Cm::Exception->INVALID_PROJECT, $url->url_peg()); + } + + if ($create) { + # The --create option is specified, create a branch + # -------------------------------------------------------------------------- + + # Check branch type flags + if ($type) { + $type = uc ($type); + + if ($type =~ /^(USER|SHARE)$/) { + $type = 'DEV' . $Fcm::Config::DELIMITER . $1; + + } elsif ($type =~ /^(CONFIG|REL)$/) { + $type = 'PKG' . $Fcm::Config::DELIMITER . $1; + + } elsif ($type =~ /^(DEV|TEST|PKG)$/) { + $type = $1 . $Fcm::Config::DELIMITER . 'USER'; + + } elsif ($type !~ /^(?:DEV|TEST|PKG)$Fcm::Config::DELIMITER(?:USER|SHARE)$/ + and $type !~ /^PKG$Fcm::Config::DELIMITER(?:CONFIG|REL)/) { + _cli_err('CLI_OPT_ARG', 'type', $type); + } + + } else { + $type = 'DEV' . $Fcm::Config::DELIMITER . 'USER'; + } + + # Check branch name + if (!$name) { + _cli_err('CLI_OPT_WITH_OPT', 'name', 'create'); + } + + if ($name !~ qr{\A[\w.-]+\z}xms) { + _cli_err('CLI_OPT_ARG', 'name', $name); + } + + # Check revision flag is valid + if ($rev_flag) { + $rev_flag = uc ($rev_flag); + if ($rev_flag !~ qr{\A (?:NORMAL|NUMBER|NONE) \z}xms) { + _cli_err('CLI_OPT_ARG', 'rev-flag', $rev_flag); + } + + } else { + $rev_flag = 'NORMAL'; + } + + # Handle multiple tickets + @tickets = split ( + /$Fcm::Config::DELIMITER_LIST/, + join ($Fcm::Config::DELIMITER_LIST, @tickets) + ); + s/^#// for (@tickets); + @tickets = sort {$a <=> $b} @tickets; + + # Determine whether to create a branch of a branch + $url->branch ('trunk') unless $branch_of_branch; + + # Create the branch + my $branch = Fcm::CmBranch->new; + $branch->create ( + SRC => $url, + TYPE => $type, + NAME => $name, + PASSWORD => $password, + REV_FLAG => $rev_flag, + TICKET => \@tickets, + REV => $rev, + NON_INTERACTIVE => $non_interactive, + SVN_NON_INTERACTIVE => $svn_non_interactive, + ); + + } elsif ($list) { + # The option --list is specified + # List branches owned by current or specified users + # -------------------------------------------------------------------------- + # Get URL of the project "branches/" sub-directory + $url->subdir (''); + $url->branch (''); + + my @branches = $url->branch_list($rev); + if (!$show_all) { + @userlist = split(qr{:}xms, join(q{:}, @userlist)); + if (!@userlist) { + @userlist = (Fcm::Config->instance()->user_id()); + } + my %filter = map {($_, 1)} @userlist; + @branches = grep { + $filter{Fcm::CmBranch->new(URL => $_)->branch_owner()} + } @branches + } + + # Output, number of branches found + $CLI_MESSAGE->( + 'BRANCH_LIST', + $url->project_url_peg(), + $rev ? "r$rev" : 'HEAD', + scalar(@branches), + ($show_all ? '[--show-all]' : join(q{, }, sort(@userlist))), + ); + + if (@branches) { + # Output the URL of each branch + if (not $verbose) { + my $project = $url->project_url; + @branches = map {Fcm::Keyword::unexpand($_)} @branches; + } + @branches = map {$_ . "\n"} sort @branches; + $CLI_MESSAGE->(q{}, join(q{}, @branches)); + + } else { + # No branch found, exit with an error code + return; + } + + } else { + # The option --info or --delete is specified + # Report branch information (and/or delete a branch) + # -------------------------------------------------------------------------- + # Set verbose level + Fcm::Config->instance()->verbose ($verbose ? 1 : 0); + + # Set up the branch, report any error + my $branch = Fcm::CmBranch->new (URL => $url->url_peg); + if (!$branch->branch()) { + return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $branch->url_peg()); + } + if (!$branch->url_exists()) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $branch->url_peg()); + } + + # Remove the sub-directory part of the URL + $branch->subdir (''); + + # Report branch info + $branch->display_info ( + SHOW_CHILDREN => ($show_all || $show_children), + SHOW_OTHER => ($show_all || $show_other ), + SHOW_SIBLINGS => ($show_all || $show_siblings), + ); + + # Delete branch if --delete is specified + $branch->del ( + PASSWORD => $password, + NON_INTERACTIVE => $non_interactive, + SVN_NON_INTERACTIVE => $svn_non_interactive, + ) if $delete; + } + +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_commit (); +# +# DESCRIPTION +# This is a FCM wrapper to the "svn commit" command. +# ------------------------------------------------------------------------------ + +sub cm_commit { + my ($dry_run, $svn_non_interactive, $password); + my $rc = GetOptions( + 'dry-run' => \$dry_run, + 'svn-non-interactive' => \$svn_non_interactive, + 'password=s' => \$password, + ); + if (!$rc) { + _cli_err(); + } + + # The remaining argument is the path to a working copy + my ($path) = @ARGV; + + if ($path) { + if (!-e $path) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path); + } + + } else { + # No argument specified, use current working directory + $path = cwd (); + } + + # Make sure we are in a working copy + if (!is_wc($path)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); + } + + # Make sure we are at the top level of the working copy + # (otherwise we might miss any template commit message) + my $dir = &get_wct ($path); + + if ($dir ne cwd ()) { + chdir($dir) || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir); + $CLI_MESSAGE->('CHDIR_WCT', $dir); + } + + # Get update status of working copy + # Check working copy files are not in conflict, missing, or out of date + my @status = _svn_status_get([], 1); + unless (defined $dry_run) { + my (@conflict, @missing, @outdate); + + for (@status) { + if (/^C/) { + push @conflict, $_; + next; + } + + if (/^!/) { + push @missing, $_; + next; + } + + if (/^.{7}\*/) { + push @outdate, $_; + next; + } + + # Check that all files which have been added have the svn:executable + # property set correctly (in case the developer adds a script before they + # remember to set the execute bit) + next unless /^A.{7} *\d+ +(.*)/; + my $file = $1; + + next unless -f $file; + my ($command, @arguments) + = (-x $file && !-l $file) ? ('propset', '*') : ('propdel'); + run_command(['svn', $command, qw{-q svn:executable}, @arguments, $file]); + } + + # Abort commit if files are in conflict, missing, or out of date + if (@conflict or @missing or @outdate) { + for ( + ['ST_CONFLICT' , \@conflict], + ['ST_MISSING' , \@missing ], + ['ST_OUT_OF_DATE', \@outdate ], + ) { + my ($key, $array_ref) = @{$_}; + if (@{$array_ref}) { + $CLI_MESSAGE->($key, join(q{}, @{$array_ref})); + } + } + return _cm_abort(Fcm::Cm::Abort->FAIL); + } + } + + # Read in any existing message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->read_file; + + # Execute "svn status" for a list of changed items + @status = grep !/^\?/, _svn_status_get(); + + # Abort if there is no change in the working copy + if (!@status) { + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + # Get associated URL of current working copy + my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ()); + + # Include URL, or project, branch and sub-directory info in @status + unshift @status, "\n"; + + if ($url->project and $url->branch) { + unshift @status, ( + '[Project: ' . $url->project . ']' . "\n", + '[Branch : ' . $url->branch . ']' . "\n", + '[Sub-dir: ' . ($url->subdir ? $url->subdir : '<top>') . ']' . "\n", + ); + + } else { + unshift @status, '[URL: ' . $url->url . ']' . "\n"; + } + + # Use a temporary file to store the final commit log message + $ci_mesg->ignore_mesg (\@status); + my $logfile = $ci_mesg->edit_file (TEMP => 1); + + # Check with the user to see if he/she wants to go ahead + my $reply = 'n'; + if (!defined($dry_run)) { + # Add extra warning for trunk commit + my @prompt_args; + my $user = Fcm::Config->instance()->user_id(); + + if ($url->is_trunk()) { + @prompt_args = ('CI_TRUNK'); + } + elsif ($user && $url->is_branch() && $url->branch_owner() ne $user) { + if (exists $Fcm::CmUrl::owner_keywords{$url->branch_owner}) { + @prompt_args = ( + 'CI_BRANCH_SHARED', + uc($Fcm::CmUrl::owner_keywords{$url->branch_owner()}), + ); + } + else { + @prompt_args = ('CI_BRANCH_USER'); + } + } + else { + @prompt_args = ('CI'); + } + $reply = $CLI_PROMPT->('commit', @prompt_args); + } + + if ($reply eq 'y') { + # Commit the change if user replies "y" for "yes" + my @command = ( + qw/svn commit -F/, $logfile, + ($svn_non_interactive ? '--non-interactive' : ()), + (defined $password ? ('--password', $password) : ()), + ); + my $rc; + &run_command (\@command, RC => \$rc, ERROR => 'warn'); + + if ($rc) { + # Commit failed + # Write temporary commit log content to commit log message file + $ci_mesg->write_file; + + # Fail the command + return _cm_abort(Fcm::Cm::Abort->FAIL); + } + + # Remove commit message file + unlink $ci_mesg->file; + + # Update the working copy + $CLI_MESSAGE->(q{}, join(q{}, _svn_update())); + + } else { + $ci_mesg->write_file; + if (!$dry_run) { + return _cm_abort(); + } + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_conflicts (); +# +# DESCRIPTION +# This is a FCM command for resolving conflicts within working copy using a +# graphical merge tool. +# ------------------------------------------------------------------------------ + +sub cm_conflicts { + # Path to the working copy + my $path = $ARGV[0]; + $path = cwd () if not $path; + + # Check for any files with conflicts + my @status = grep /^C.{4} *(.*)/, &run_command ( + [qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx', + ); + my @files = map {m/^C.{4} *(.*)/; $1} @status; + + # Save current working directory + my $topdir = cwd (); + + # Set up environment for graphical merge + # Use environment variable if set, otherwise use default setting + local(%ENV) = %ENV; + $ENV{FCM_GRAPHIC_MERGE} + ||= Fcm::Config->instance()->setting (qw/TOOL GRAPHIC_MERGE/); + + FILE: + for my $file (@files) { + # Print name of file in conflicts + $CLI_MESSAGE->('CF', $file); + + # Determine directory and base name of file in conflicts + my $base = basename $file; + my $dir = dirname $file; + + # Change to container directory of file in conflicts + chdir(File::Spec->catfile($topdir, $dir)) + || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir); + + # Use "svn info" to determine conflict marker files + my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx'); + + # Ignore if $base is a binary file + if (-B $base) { + $CLI_MESSAGE->('CF_BINARY', $base); + next FILE; + } + + # Get conflicts markers files + my ($older, $mine, $yours); + + for (@info) { + $older = $1 if (/^Conflict Previous Base File: (.*)/); + $mine = $1 if (/^Conflict Previous Working File: (.*)/); + $yours = $1 if (/^Conflict Current Base File: (.*)/); + } + + if (-f $base and (stat $base)[9] > (stat $mine)[9] + 1) { + # If $base is newer (by more than a second), it may contain saved changes + if ($CLI_PROMPT->('conflicts', 'CF_OVERWRITE', $base) ne 'y') { + next FILE; + } + } + + # Launch graphic merge tool + my $rc; + my $command = [qw/fcm_graphic_merge/, $base, $mine, $older, $yours]; + # $rc == 0: all conflicts resovled + # $rc == 1: some conflicts not resolved + # $rc == 2: trouble + eval { + run_command($command, RC => \$rc); + }; + if ($@) { + if (!defined($rc) || $rc > 1) { + die($@); + } + } + next FILE if $rc; + + # Prompt user to run "svn resolved" on the file + if ($CLI_PROMPT->('conflicts', 'RUN_SVN_COMMAND', 'resolved') eq 'y') { + run_command([qw{svn resolved}, $base]); + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_diff (); +# +# DESCRIPTION +# This is a wrapper to "svn diff". It adds two extra functionalities. The +# first one allows the command to show differences relative to the base of +# the branch. The second one allows differences to be displayed via a +# graphical tool. +# ------------------------------------------------------------------------------ + +sub cm_diff { + # Set up environment for graphical diff + # Use environment variable if set, otherwise use default setting + local(%ENV) = %ENV; + $ENV{FCM_GRAPHIC_DIFF} + ||= Fcm::Config->instance()->setting(qw/TOOL GRAPHIC_DIFF/); + + # Check for the --branch options + # ---------------------------------------------------------------------------- + my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV; + + if (not $branch) { + # The --branch option not specified, just call "svn diff" + # Convert the --graphical to qw/--diff-cmd fcm_graphical_diff/ + # Convert the --summarise to --summarize + @ARGV = map { + my @return; + if ($_ eq '-g' or $_ eq '--graphical') { + @return = (qw/--diff-cmd fcm_graphic_diff/) + + } elsif ($_ eq '--summarise') { + @return = ('--summarize'); + + } else { + @return = ($_); + } + @return; + } @ARGV; + + # Execute the command + return _svn('diff', @ARGV); + } + + # The --branch option is specified + # ---------------------------------------------------------------------------- + + # Determine whether the --graphical option is specified, + # if so set the appropriate command + # ---------------------------------------------------------------------------- + my ($diff_cmd, $extensions, $graphical, $summarise, $trac, $wiki); + my $rc = GetOptions ( + 'b|branch' => \$branch, + 'diff-cmd=s' => \$diff_cmd, + 'x|extensions=s' => \$extensions, + 'g|graphical' => \$graphical, + 'summarise|summarize' => \$summarise, + 't|trac' => \$trac, + 'wiki' => \$wiki, + ); + if (!$rc) { + _cli_err(); + } + + my @diff_cmd = (); + + if ($graphical) { + @diff_cmd = (qw/--diff-cmd fcm_graphic_diff/); + + } elsif ($diff_cmd) { + @diff_cmd = ('--diff-cmd', $diff_cmd); + + push @diff_cmd, '--extensions', split (/\s+/, $extensions) if $extensions; + } + + # The remaining argument should either be a URL or a PATH + my ($url_arg, $path_arg); + + if (@ARGV) { + my $arg = Fcm::CmUrl->new (URL => $ARGV[0]); + + if ($arg->is_url) { + $url_arg = $ARGV[0]; + + } else { + $path_arg = $ARGV[0]; + } + } + + # Get repository and branch information + # ---------------------------------------------------------------------------- + my ($url, $path); + if (defined $url_arg) { + # If a URL is specified, get repository and branch information from it + $url = Fcm::CmBranch->new (URL => $url_arg); + + } else { + # Get repository and branch information from the specified path or the + # current directory if it is a working copy + $path = $path_arg ? $path_arg : cwd (); + if (!is_wc($path)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); + } + + $url = Fcm::CmBranch->new (URL => &get_url_peg_of_wc ($path)); + } + + # Check that URL is a standard FCM branch + if (!$url->is_branch()) { + return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $url->url_peg()); + } + + # Save and remove sub-directory part of the URL + my $subdir = $url->subdir (); + $url->subdir (''); + + # Check that $url exists + if (!$url->url_exists()) { + return _cm_err(Fcm::Cm::Exception->INVALID_URL, $url->url_peg()); + } + + # Compare current branch with its parent + # ---------------------------------------------------------------------------- + my $parent = Fcm::CmBranch->new (URL => $url->parent->url); + $parent->pegrev ($url->pegrev) if $url->pegrev; + + if (!$parent->url_exists()) { + return _cm_err( + Fcm::Cm::Exception->PARENT_NOT_EXIST, $url->url_peg(), $parent->url(), + ); + } + + my $base = $parent->base_of_merge_from ($url); + + # Ensure the correct diff (syntax) is displayed + # ---------------------------------------------------------------------------- + # Reinstate the sub-tree part into the URL + $url->subdir ($subdir); + $base->subdir ($subdir); + + # Ensure the branch URL has a peg revision + $url->pegrev ($url->svninfo (FLAG => 'Last Changed Rev')) if not $url->pegrev; + + if ($trac or $wiki) { + # Trac/wiki + # -------------------------------------------------------------------------- + if (!$url_arg && _svn_status_get([$path_arg ? $path_arg : q{.}])) { + $CLI_MESSAGE->('ST_IN_TRAC_DIFF', ($path_arg ? $path_arg : q{.})); + } + + # Trac wiki syntax + my $wiki_syntax = 'diff:' . $base->path_peg . '//' . $url->path_peg; + + if ($wiki) { + # Print Trac wiki syntax only + $CLI_MESSAGE->(q{}, "$wiki_syntax\n"); + + } else { # if $trac + # Use Trac to view "diff" + my $browser = Fcm::Config->instance()->setting(qw/WEB_BROWSER/); + $browser ||= 'firefox'; + + my $trac_url = Fcm::Keyword::get_browser_url($url->project_url()); + $trac_url =~ s{/intertrac/.*$}{/intertrac/$wiki_syntax}xms; + + &run_command ([$browser, $trac_url], METHOD => 'exec', PRINT => 1); + } + + } else { + # Execute the "diff" command + # -------------------------------------------------------------------------- + my @command = ( + qw/svn diff/, @diff_cmd, + ($summarise ? ('--summarize') : ()), + '--old', $base->url_peg, + '--new', ($url_arg ? $url->url_peg : ($path_arg ? $path_arg : '.')), + ); + &run_command (\@command, PRINT => 1); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_merge (); +# +# DESCRIPTION +# This is a wrapper to "svn merge". +# ------------------------------------------------------------------------------ + +sub cm_merge { + # Options + # ---------------------------------------------------------------------------- + my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose); + my $rc = GetOptions( + 'custom' => \$custom, + 'dry-run' => \$dry_run, + 'non-interactive' => \$non_interactive, + 'reverse' => \$reverse, + 'revision|r=s' => \$rev, + 'verbose|v' => \$verbose, + ); + if (!$rc) { + _cli_err(); + } + + # Find out the URL of the working copy + # ---------------------------------------------------------------------------- + my ($target, $wct); + if (&is_wc ()) { + $wct = &get_wct (); + + if ($wct ne cwd ()) { + chdir($wct) || return _cm_err(Fcm::Cm::Exception->CHDIR, $wct); + $CLI_MESSAGE->('CHDIR_WCT', $wct); + } + + $target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct)); + + } else { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, '.'); + } + + if (!$target->url_exists()) { + return _cm_err(Fcm::Cm::Exception->WC_URL_NOT_EXIST, '.'); + } + + # The target must be at the top of a branch + # $subdir will be used later to determine whether the merge is allowed or not + my $subdir = $target->subdir; + $target->subdir ('') if $subdir; + + # Check for any local modifications + # ---------------------------------------------------------------------------- + if (!$dry_run && !$non_interactive) { + _svn_status_checker('merge', 'MODIFIED', $CLI_HANDLER_OF{WC_STATUS})->(); + } + + # Determine the SOURCE URL + # ---------------------------------------------------------------------------- + my $source; + + if ($reverse) { + # Reverse merge, the SOURCE is the the working copy URL + $source = Fcm::CmBranch->new (URL => $target->url); + + } else { + # Automatic/custom merge, argument 1 is the SOURCE of the merge + my $source_url = shift (@ARGV); + if (!$source_url) { + _cli_err('CLI_MERGE_ARG1'); + } + + $source = _cm_get_source($source_url, $target); + } + + # Parse the revision option + # ---------------------------------------------------------------------------- + if ($reverse && !$rev) { + _cli_err('CLI_OPT_WITH_OPT', 'revision', 'reverse'); + } + my @revs = (($reverse || $custom) && $rev ? split(qr{:}xms, $rev) : ()); + + # Determine the merge delta and the commit log message + # ---------------------------------------------------------------------------- + my (@delta, $mesg); + my $separator = '-' x 80 . "\n"; + + if ($reverse) { + # Reverse merge + # -------------------------------------------------------------------------- + if (@revs == 1) { + $revs[1] = ($revs[0] - 1); + + } else { + @revs = sort {$b <=> $a} @revs; + } + + $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) + unless $source->pegrev; + $source->subdir ($subdir); + + # "Delta" of the "svn merge" command + @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg); + + # Template message + $mesg = 'Reversed r' . $revs[0] . + (($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' . + $source->path . "\n"; + + } elsif ($custom) { + # Custom merge + # -------------------------------------------------------------------------- + if (@revs) { + # Revision specified + # ------------------------------------------------------------------------ + # Only one revision N specified, use (N - 1):N as the delta + unshift @revs, ($revs[0] - 1) if @revs == 1; + + $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) + unless $source->pegrev; + $source->subdir ($subdir); + $target->subdir ($subdir); + + # "Delta" of the "svn merge" command + @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg); + + # Template message + $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] . + ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n"; + + } else { + # Revision not specified + # ------------------------------------------------------------------------ + # Get second source URL + my $source2_url = shift (@ARGV); + if (!$source2_url) { + _cli_err('CLI_MERGE_ARG2'); + } + + my $source2 = _cm_get_source($source2_url, $target); + + $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) + unless $source->pegrev; + $source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev')) + unless $source2->pegrev; + $source->subdir ($subdir); + $source2->subdir ($subdir); + $target->subdir ($subdir); + + # "Delta" of the "svn merge" command + @delta = ($source->url_peg, $source2->url_peg); + + # Template message + $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg . + ' cf. ' . $source2->path_peg . "\n"; + } + + } else { + # Automatic merge + # -------------------------------------------------------------------------- + # Check to ensure source branch is not the same as the target branch + if (!$target->branch()) { + return _cm_err(Fcm::Cm::Exception->WC_INVALID_BRANCH, $wct); + } + if ($source->branch() eq $target->branch()) { + return _cm_err(Fcm::Cm::Exception->MERGE_SELF, $target->url_peg(), $wct); + } + + # Only allow the merge if the source and target are "directly related" + # -------------------------------------------------------------------------- + my $anc = $target->ancestor ($source); + return _cm_err( + Fcm::Cm::Exception->MERGE_UNRELATED, $target->url_peg(), $source->url_peg + ) unless + ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg) + or + ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg) + or + ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url); + + # Check for available merges from the source + # -------------------------------------------------------------------------- + my @revs = $target->avail_merge_from ($source, 1); + + if (@revs) { + if ($verbose) { + # Verbose mode, print log messages of available merges + $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), q{}); + for (@revs) { + $CLI_MESSAGE->('SEPARATOR'); + $CLI_MESSAGE->(q{}, $source->display_svnlog($_)); + } + $CLI_MESSAGE->('SEPARATOR'); + } + else { + # Normal mode, list revisions of available merges + $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), join(q{ }, @revs)); + } + + } else { + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + # If more than one merge available, prompt user to enter a revision number + # to merge from, default to $revs [0] + # -------------------------------------------------------------------------- + if ($non_interactive || @revs == 1) { + $source->pegrev($revs[0]); + } + else { + my $reply = $CLI_PROMPT->( + {type => q{}, default => $revs[0]}, 'merge', 'MERGE_REV', + ); + if (!defined($reply)) { + return _cm_abort(); + } + # Expand revision keyword if necessary + if ($reply) { + $reply = (Fcm::Keyword::expand($target->project_url(), $reply))[1]; + } + # Check that the reply is a number in the available merges list + if (!grep {$_ eq $reply} @revs) { + return _cm_err(Fcm::Cm::Exception->MERGE_REV_INVALID, $reply) + } + $source->pegrev($reply); + } + + # If the working copy top is pointing to a sub-directory of a branch, + # we need to check whether the merge will result in losing changes made in + # other sub-directories of the source. + if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) { + return _cm_err(Fcm::Cm::Exception->MERGE_UNSAFE, $source->url_peg()); + } + + # Calculate the base of the merge + my $base = $target->base_of_merge_from ($source); + + # $source and $base must take into account the sub-directory + my $s = Fcm::CmBranch->new (URL => $source->url_peg); + my $b = Fcm::CmBranch->new (URL => $base->url_peg); + + $s->subdir ($subdir) if $subdir; + $b->subdir ($subdir) if $subdir; + + # Diagnostic + $CLI_MESSAGE->('MERGE_CF', $s->path_peg(), $b->path_peg()); + + # Delta of the "svn merge" command + @delta = ($b->url_peg, $s->url_peg); + + # Template message + $mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg . + ' cf. ' . $base->path_peg . "\n"; + } + + # Run "svn merge" in "--dry-run" mode to see the result + # ---------------------------------------------------------------------------- + my @out = &run_command ( + [qw/svn merge --dry-run/, @delta], + METHOD => 'qx', PRINT => ($dry_run and $verbose), + ); + + # Abort merge if it will result in no change + if (not @out) { + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + # Report result of "svn merge --dry-run" + if ($dry_run || !$non_interactive) { + $CLI_MESSAGE->('MERGE_DRY'); + $CLI_MESSAGE->('SEPARATOR'); + $CLI_MESSAGE->(q{}, join(q{}, @out)); + $CLI_MESSAGE->('SEPARATOR'); + } + + return if $dry_run; + + # Prompt the user to see if (s)he would like to go ahead + # ---------------------------------------------------------------------------- + # Go ahead with merge only if user replies "y" + if (!$non_interactive && $CLI_PROMPT->('merge', 'MERGE') ne 'y') { + return _cm_abort(); + } + $CLI_MESSAGE->('MERGE'); + run_command([qw/svn merge/, @delta], PRINT => $verbose); + + # Prepare the commit log + # ---------------------------------------------------------------------------- + # Read in any existing message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->read_file; + $ci_mesg->auto_mesg ([$mesg, @{ $ci_mesg->auto_mesg }]); + $ci_mesg->write_file; + + if ($verbose) { + $CLI_MESSAGE->('SEPARATOR'); + $CLI_MESSAGE->('MERGE_CI', $mesg); + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_mkpatch (); +# +# DESCRIPTION +# This is a FCM command to create a patching script from particular revisions +# of a URL. +# ------------------------------------------------------------------------------ + +sub cm_mkpatch { + # Process command line options and arguments + # ---------------------------------------------------------------------------- + my (@exclude, $organisation, $revision); + my $rc = GetOptions( + 'exclude=s' => \@exclude, + 'organisation=s' => \$organisation, + 'r|revision=s' => \$revision, + ); + if (!$rc) { + _cli_err(); + } + + # Excluded paths, convert glob into regular patterns + @exclude = split (/:/, join (':', @exclude)); + for (@exclude) { + s#\*#[^/]*#; # match any number of non-slash character + s#\?#[^/]#; # match a non-slash character + s#/*$##; # remove trailing slash + } + + # Organisation prefix + $organisation = $organisation ? $organisation : 'original'; + + # Make sure revision option is set correctly + my @revs = $revision ? split (/:/, $revision) : (); + @revs = @revs [0, 1] if @revs > 2; + + # Arguments + my ($u, $outdir) = @ARGV; + + if (!$u) { + _cli_err(); + } + + my $url = Fcm::CmUrl->new (URL => $u); + if (!$url->is_url()) { + return _cm_err(Fcm::Cm::Exception->INVALID_URL, $u); + } + if (!$url->url_exists()) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $u); + } + if (!$url->branch()) { + $CLI_MESSAGE->('INVALID_BRANCH', $u); + } + elsif ($url->subdir()) { + $CLI_MESSAGE->('BRANCH_SUBDIR', $u); + } + + if (@revs) { + # If HEAD revision is given, convert it into a number + # -------------------------------------------------------------------------- + for my $rev (@revs) { + $rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD'; + } + + } else { + # If no revision is given, use the HEAD + # -------------------------------------------------------------------------- + $revs[0] = $url->svninfo (FLAG => 'Revision'); + } + + $revs[1] = $revs[0] if @revs == 1; + + # Check that output directory is set + # ---------------------------------------------------------------------------- + $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir; + + if (-e $outdir) { + # Ask user to confirm removal of old output directory if it exists + if ($CLI_PROMPT->('mkpatch', 'MKPATCH_OVERWRITE') ne 'y') { + return _cm_abort(); + } + + rmtree($outdir) || return _cm_err(Fcm::Cm::Exception->RMTREE, $outdir); + } + + # (Re-)create output directory + mkpath($outdir) || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir); + $CLI_MESSAGE->('OUT_DIR', $outdir); + + # Get and process log of URL + # ---------------------------------------------------------------------------- + my @script = (); # main output script + my %log = $url->svnlog (REV => \@revs); + my $url_path = $url->path; + + for my $rev (sort {$a <=> $b} keys %log) { + # Look at the changed paths for each revision + my $use_patch = 1; # OK to use a patch file? + my @paths; + PATH: for my $path (sort keys %{ $log{$rev}{paths} }) { + my $file = $path; + + # Skip paths outside of the branch + next PATH unless $file =~ s#^$url_path/*##; + + # Skip excluded paths + for my $exclude (@exclude) { + if ($file =~ m#^$exclude(?:/*|$)#) { + # Can't use a patch file if any files have been excluded + $use_patch = 0; + next PATH; + } + } + + # Can't use a patch file if any files have been added or replaced + $use_patch = 0 if $log{$rev}{paths}{$path}{action} eq 'A' or + $log{$rev}{paths}{$path}{action} eq 'R'; + + push @paths, $path; + } + + # If a patch is being used, make sure it isn't just property changes + if ($use_patch) { + my @changedpaths; + for my $path (@paths) { + (my $file = $path) =~ s#^$url_path/*##; + if ($log{$rev}{paths}{$path}{action} eq 'M') { + my ($diff) = &run_command ( + [qw/svn diff --no-diff-deleted --summarize -c/, + $rev, $url->url . '/' . $file. '@' . $rev], + METHOD => 'qx'); + next unless $diff =~ /^[A-Z]/; + } + push @changedpaths, $path; + } + @paths = @changedpaths; + } + + next unless @paths; + + # Create the patch using "svn diff" + my @patch = (); + if ($use_patch) { + @patch = &run_command ([qw/svn diff --no-diff-deleted -c/, $rev, + $url->url], METHOD => 'qx'); + if (@patch) { + # Don't use the patch if it may contain subversion keywords + for (@patch) { + $use_patch = 0 if /\$[a-zA-Z:]+ *\$/; + } + } else { + $use_patch = 0; + } + } + + # Create a directory for this revision in the output directory + my $outdir_rev = File::Spec->catfile ($outdir, $rev); + mkpath($outdir_rev) + || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir_rev); + + # Parse commit log message + my @msg = split /\n/, $log{$rev}{msg}; + for (@msg) { + # Re-instate line break + $_ .= "\n"; + + # Remove line if it matches a merge template + $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/; + $_ = '' if /^Custom merge into \S+:.+$/; + $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/; + + # Modify Trac ticket link + s/(?:#|ticket:)(\d+)/${organisation}_ticket:$1/g; + + # Modify Trac changeset link + s/(?:r|changeset:)(\d+)/${organisation}_changeset:$1/g; + s/\[(\d+)\]/${organisation}_changeset:$1/g; + } + + push @msg, '(' . $organisation . '_changeset:' . $rev . ')' . "\n"; + + # Write commit log message in a file + my $f_revlog = File::Spec->catfile ($outdir_rev, 'log-message'); + open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')'; + print FILE @msg; + close FILE or die $f_revlog, ': cannot close (', $!, ')'; + + # Handle each changed path + my $export_file = 1; # name for next exported file (gets incremented) + my $patch_needed = 0; # is a patch file required? + my @before_script = (); # patch script to run before patch applied + my @after_script = (); # patch script to run after patch applied + my @copied_dirs = (); # copied directories + CHANGED: for my $path (@paths) { + (my $file = $path) =~ s#^$url_path/*##; + my $url_file = $url->url . '/' . $file . '@' . $rev; + + # Skip paths within copied directories + for my $copied_dir (@copied_dirs) { + next CHANGED if $file =~ m#^$copied_dir(?:/*|$)#; + } + + if ($log{$rev}{paths}{$path}{action} eq 'D') { + # Script to delete file + push @after_script, 'svn delete ' . $file; + + } else { + my $export_required = 0; + my $recursive_add = 0; + my $is_newfile = 0; + + # Skip property changes + if ($log{$rev}{paths}{$path}{action} eq 'M') { + my ($diff) = &run_command ( + [qw/svn diff --no-diff-deleted --summarize -c/, + $rev, $url->url . '/' . $file. '@' . $rev], + METHOD => 'qx'); + next CHANGED unless $diff =~ /^[A-Z]/; + } + + # Determine if the file is a directory + my $is_dir = 0; + if ($log{$rev}{paths}{$path}{action} ne 'M') { + my @info = &run_command ([qw/svn info/, $url_file], METHOD => 'qx'); + for (@info) { + if (/^Node Kind: (\w+)/) { + $is_dir = 1 if $1 eq 'directory'; + last; + } + } + } + + # Decide how to treat added files + if ($log{$rev}{paths}{$path}{action} eq 'A') { + # Determine if the file is copied + if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) { + if ($is_dir) { + # A copied directory needs to be treated as a new file, exported + # and added recursively + $is_newfile = 1; + $export_required = 1; + $recursive_add = 1; + push @copied_dirs, $file; + } else { + # History exists for this file + my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'}; + my $copyfrom_rev = $log{$rev}{paths}{$path}{'copyfrom-rev'}; + my $cp_url = Fcm::CmUrl->new ( + URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev, + ); + + if ($copyfrom_path =~ s#^$url_path/*##) { + # File is copied from a file under the specified URL + # Check source exists + $is_newfile = 1 unless $cp_url->url_exists ($rev - 1); + } else { + # File copied from outside of the specified URL + $is_newfile = 1; + + # Check branches can be determined + if ($url->branch and $cp_url->branch) { + + # Follow its history, stop on copy + my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1); + + # "First" revision of the copied file + my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0]; + my %attrib = %{ $cp_log{$cp_rev}{paths}{$cp_url->path} } + if $cp_log{$cp_rev}{paths}{$cp_url->path}; + + # Check whether the "first" revision is copied from elsewhere. + if (exists $attrib{'copyfrom-path'}) { + # If source exists in the specified URL, set up the copy + my $cp_cp_url = Fcm::CmUrl->new ( + URL => $url->root . $attrib{'copyfrom-path'} . '@' . + $attrib{'copyfrom-rev'}, + ); + $cp_cp_url->branch ($url->branch); + if ($cp_cp_url->url_exists ($rev - 1)) { + ($copyfrom_path = $cp_cp_url->path) =~ s#^$url_path/*##; + # Check path is defined - if not it probably means the + # branch doesn't follow the FCM naming convention + $is_newfile = 0 if $copyfrom_path; + } + } + + # Note: The logic above does not cover all cases. However, it + # should do the right thing for the most common case. Even + # where it gets it wrong the file contents should always be + # correct even if the file history is not. + } + } + + # Check whether file is copied from an excluded path + if (not $is_newfile) { + for my $exclude (@exclude) { + if ($copyfrom_path =~ m#^$exclude(?:/*|$)#) { + $is_newfile = 1; + last; + } + } + } + + # Script to copy file, if required + push @before_script, 'svn copy ' . $copyfrom_path . ' ' . $file + if not $is_newfile; + } + + } else { + # History does not exist, must be a new file + $is_newfile = 1; + # If it's a directory then create it (in case patch doesn't) + push @before_script, 'mkdir ' . $file if $is_dir; + } + } + + if ($log{$rev}{paths}{$path}{action} eq 'R') { + # Script to delete file + push @before_script, 'svn delete ' . $file; + + # Now treat as new file + $is_newfile = 1; + } + + # Script to add the file, if required + if ($is_newfile) { + if ($recursive_add) { + push @after_script, 'svn add ' . $file; + } else { + push @after_script, 'svn add --non-recursive ' . $file; + } + } + + # Decide whether the file needs to be exported + if (not $is_dir) { + if (not $use_patch) { + $export_required = 1; + } else { + # Export the file if it is binary + my @mime_type = &run_command + ([qw/svn propget svn:mime-type/, $url_file], METHOD => 'qx'); + for (@mime_type) { + $export_required = 1 if not /^text\//; + } + # Only create a patch file if necessary + $patch_needed = 1 if not $export_required; + } + } + + if ($export_required) { + # Download the file using "svn export" + my $export = File::Spec->catfile ($outdir_rev, $export_file); + &run_command ([qw/svn export -q -r/, $rev, $url_file, $export]); + + # Copy the exported file into the file + push @before_script, + 'cp -r ${fcm_patch_dir}/' . $export_file . ' ' . $file; + $export_file++; + } + } + } + + # Write the patch file + if ($patch_needed) { + my $patchfile = File::Spec->catfile ($outdir_rev, 'patchfile'); + open FILE, '>', $patchfile + or die $patchfile, ': cannot open (', $!, ')'; + print FILE @patch; + close FILE or die $patchfile, ': cannot close (', $!, ')'; + } + + # Add line break to each line in @before_script and @after_script + @before_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} + @before_script if (@before_script); + @after_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} + @after_script if (@after_script); + + # Write patch script to output + my $out = File::Spec->catfile ($outdir_rev, 'apply-patch'); + open FILE, '>', $out or die $out, ': cannot open (', $!, ')'; + + # Script header + my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/); + print FILE <<EOF; +#!$shell +# ------------------------------------------------------------------------------ +# NAME +# apply-patch +# +# DESCRIPTION +# This script is generated automatically by the "fcm mkpatch" command. It +# applies the patch to the current working directory which must be a working +# copy of a valid project tree that can accept the import of the patches. +# +# Patch created from $organisation URL: $u +# Changeset: $rev +# ------------------------------------------------------------------------------ + +this=`basename \$0` +echo "\$this: Applying patch for changeset $rev." + +# Location of the patch, base on the location of this script +cd `dirname \$0` || exit 1 +fcm_patch_dir=\$PWD + +# Change directory back to the working copy +cd \$OLDPWD || exit 1 + +# Check working copy does not have local changes +status=`svn status` +if [[ -n \$status ]]; then + echo "\$this: working copy contains changes, abort." >&2 + exit 1 +fi +if [[ -a "#commit_message#" ]]; then + echo "\$this: existing commit message in "#commit_message#", abort." >&2 + exit 1 +fi + +# Apply the changes +EOF + + # Script content + print FILE @before_script if @before_script; + print FILE "patch -p0 <\${fcm_patch_dir}/patchfile || exit 1\n" + if $patch_needed; + print FILE @after_script if @after_script; + + # Script footer + print FILE <<EOF; + +# Copy in the commit message +cp \${fcm_patch_dir}/log-message "#commit_message#" + +echo "\$this: finished normally." +#EOF +EOF + + close FILE or die $out, ': cannot close (', $!, ')'; + + # Add executable permission + chmod 0755, $out; + + # Script to commit the change + push @script, '${fcm_patches_dir}/' . $rev . '/apply-patch'; + push @script, 'svn commit -F "#commit_message#"'; + push @script, 'rm -f "#commit_message#"'; + push @script, 'svn update'; + push @script, ''; + + $CLI_MESSAGE->('PATCH_REV', $rev); + } + + # Write the main output script if necessary. Otherwise remove output directory + # ---------------------------------------------------------------------------- + if (@script) { + # Add line break to each line in @script + @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script; + + # Write script to output + my $out = File::Spec->catfile ($outdir, 'fcm-import-patch'); + open FILE, '>', $out or die $out, ': cannot open (', $!, ')'; + + # Script header + my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/); + print FILE <<EOF; +#!$shell +# ------------------------------------------------------------------------------ +# NAME +# fcm-import-patch +# +# SYNOPSIS +# fcm-import-patch TARGET +# +# DESCRIPTION +# This script is generated automatically by the "fcm mkpatch" command, as are +# the revision "patches" created in the same directory. The script imports the +# patches into TARGET, which must either be a URL or a working copy of a valid +# project tree that can accept the import of the patches. +# +# Patch created from $organisation URL: $u +# ------------------------------------------------------------------------------ + +this=`basename \$0` + +# Check argument +target=\$1 + +# First argument must be a URL or working copy +if [[ -z \$target ]]; then + echo "\$this: the first argument must be a URL or a working copy, abort." >&2 + exit 1 +fi + +if [[ \$target == svn://* || \$target == svn+ssh://* || \\ + \$target == http://* || \$target == https://* || \\ + \$target == file://* ]]; then + # A URL, checkout a working copy in a temporary location + fcm_tmp_dir=`mktemp -d \${TMPDIR:=/tmp}/\$this.XXXXXX` + fcm_working_copy=\$fcm_tmp_dir + svn checkout -q \$target \$fcm_working_copy || exit 1 +else + fcm_working_copy=\$target +fi + +# Location of the patches, base on the location of this script +cd `dirname \$0` || exit 1 +fcm_patches_dir=\$PWD + +# Change directory to the working copy +cd \$fcm_working_copy || exit 1 + +# Set the language to avoid encoding problems +export LANG=en_GB + +# Commands to apply patches +EOF + + # Script content + print FILE @script; + + # Script footer + print FILE <<EOF; +# Remove temporary working copy, if necessary +if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then + rm -rf \$fcm_tmp_dir +fi + +echo "\$this: finished normally." +#EOF +EOF + + close FILE or die $out, ': cannot close (', $!, ')'; + + # Add executable permission + chmod 0755, $out; + + # Diagnostic + $CLI_MESSAGE->('PATCH_DONE', $outdir); + + } else { + # Remove output directory + rmtree $outdir or die $outdir, ': cannot remove'; + + # Diagnostic + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# CLI: fcm add. +sub _cli_command_add { + my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_; + my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'}); + return ( + @args == @_ ? _svn("add", @args) : cm_check_unknown(\%option, @args) + ); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm checkout. +sub _cli_command_checkout { + if (@ARGV) { + my $target = is_url($ARGV[-1]) ? cwd() : $ARGV[-1]; + if (-d $target && is_wc($target)) { + return _cm_err(Fcm::Cm::Exception->WC_EXIST, $target); + } + } + return _svn('checkout', @ARGV); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm delete. +sub _cli_command_delete { + my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_; + my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'}); + return ( + @args == @_ ? _svn("delete", @args) : cm_check_missing(\%option, @args) + ); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm switch. +sub _cli_command_switch { + local(@ARGV) = @_; + if (grep {$_ eq '--relocate'} @ARGV) { + return _svn('switch', @ARGV); + } + my %option; + if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) { + _cli_err(); + } + if (!$option{'non-interactive'}) { + $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS}; + } + if (!@ARGV) { + _cli_err(); + } + $CLI_MESSAGE->(q{}, join(q{}, cm_switch(\%option, @ARGV))); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm update. +sub _cli_command_update { + local(@ARGV) = @_; + my %option; + if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) { + _cli_err(); + } + if (!$option{'non-interactive'}) { + $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS}; + } + $CLI_MESSAGE->(q{}, join(q{}, cm_update(\%option, @ARGV))); +} + +# ------------------------------------------------------------------------------ +# CLI error. +sub _cli_err { + my ($key, @args) = @_; + $key ||= 'CLI_USAGE'; + my $message = sprintf($CLI_MESSAGE_FOR_ERROR{$key}, @args); + die(Fcm::CLI::Exception->new({message => $message})); +} + +# ------------------------------------------------------------------------------ +# Handles abort exception. +sub _cli_e_handler_of_cm_abort { + my ($function, $e) = @_; + if ($e->get_code() eq $e->FAIL) { + die(sprintf($CLI_MESSAGE_FOR_ABORT{FAIL}, $function)); + } + else { + $CLI_MESSAGE->($e->get_code(), $function); + } +} + +# ------------------------------------------------------------------------------ +# Handles CM exception. +sub _cli_e_handler_of_cm_exception { + my ($function, $e) = @_; + die(sprintf($CLI_MESSAGE_FOR_ERROR{$e->get_code()}, $e->get_targets())); +} + +# ------------------------------------------------------------------------------ +# Handles CLI exception. +sub _cli_e_handler_of_cli_exception { + my ($function, $e) = @_; + $CLI_MESSAGE->('CLI', $e); + $CLI_MESSAGE->('CLI_HELP', $function); +} + +# ------------------------------------------------------------------------------ +# The default handler of the "WC_STATUS" event. +sub _cli_handler_of_wc_status { + my ($name, $target_list_ref, $status_list_ref) = @_; + if (@{$status_list_ref}) { + $CLI_MESSAGE->('STATUS', join(q{}, @{$status_list_ref})); + if ($CLI_PROMPT->($name, 'CONTINUE') ne 'y') { + return _cm_abort(); + } + } + return @{$status_list_ref}; +} + +# ------------------------------------------------------------------------------ +# The default handler of the "WC_STATUS_PATH" event. +sub _cli_handler_of_wc_status_path { + my ($name, $target_list_ref, $status_list_ref) = @_; + $CLI_MESSAGE->(q{}, join(q{}, @{$status_list_ref})); + my @paths = map {chomp(); ($_ =~ $PATTERN_OF{ST_PATH})} @{$status_list_ref}; + my @paths_of_interest; + while (my $path = shift(@paths)) { + my %handler_of = ( + a => sub {push(@paths_of_interest, $path, @paths); @paths = ()}, + n => sub {}, + y => sub {push(@paths_of_interest, $path)}, + ); + my $reply = $CLI_PROMPT->( + {type => 'yna'}, $name, 'RUN_SVN_COMMAND', "$name $path", + ); + $handler_of{$reply}->(); + } + return @paths_of_interest; +} + +# ------------------------------------------------------------------------------ +# Prints help for a given $subcommand. +sub _cli_help { + my ($key, $exit_val) = @_; + my $pod + = File::Spec->catfile(dirname($INC{'Fcm/Cm.pm'}), 'CLI', "fcm-$key.pod"); + my $has_pod = -f $pod; + if ($has_pod) { + pod2usage({ + '-exitval' => defined($exit_val) ? $exit_val : 2, + '-input' => $pod, + '-verbose' => 1, + }); + } + if (!$has_pod || exists($CLI_MORE_HELP_FOR{$key})) { + local(@ARGV) = ($key); + return _svn('help', $key); + } +} + +# ------------------------------------------------------------------------------ +# Expands location keywords in a list. +sub _cli_keyword_expand_url { + my ($arg_list_ref) = @_; + ARG: + for my $arg (@{$arg_list_ref}) { + my ($label, $value) = ($arg =~ $PATTERN_OF{CLI_OPT}); + if (!$label) { + ($label, $value) = (q{}, $arg); + } + if (!$value) { + next ARG; + } + eval { + $value = Fcm::Util::tidy_url(Fcm::Keyword::expand($value)); + }; + if ($@) { + if ($value ne 'fcm:revision') { + die($@); + } + } + $arg = $label . $value; + } +} + +# ------------------------------------------------------------------------------ +# Expands revision keywords in -r and --revision options in a list. +sub _cli_keyword_expand_rev { + my ($arg_list_ref) = @_; + my @targets; + for my $arg (@{$arg_list_ref}) { + if (-e $arg && is_wc($arg) || is_url($arg)) { + push(@targets, $arg); + } + } + if (!@targets) { + push(@targets, get_url_of_wc()); + } + if (!@targets) { + return; + } + my @old_arg_list = @{$arg_list_ref}; + my @new_arg_list = (); + ARG: + while (defined(my $arg = shift(@old_arg_list))) { + my ($key, $value) = $arg =~ $PATTERN_OF{CLI_OPT_REV}; + if (!$key) { + push(@new_arg_list, $arg); + next ARG; + } + push(@new_arg_list, '--revision'); + if (!$value) { + $value = shift(@old_arg_list); + } + my @revs = grep {defined()} ($value =~ $PATTERN_OF{CLI_OPT_REV_RANGE}); + my ($url, @url_list) = @targets; + for my $rev (@revs) { + if ($rev !~ $PATTERN_OF{SVN_REV}) { + $rev = (Fcm::Keyword::expand($url, $rev))[1]; + } + if (@url_list) { + $url = shift(@url_list); + } + } + push(@new_arg_list, join(q{:}, @revs)); + } + @{$arg_list_ref} = @new_arg_list; +} + +# ------------------------------------------------------------------------------ +# Prints a message. +sub _cli_message { + my ($key, @args) = @_; + for ( + [\*STDOUT, \%CLI_MESSAGE_FOR , q{} ], + [\*STDERR, \%CLI_MESSAGE_FOR_WARNING, q{[WARNING] }], + [\*STDERR, \%CLI_MESSAGE_FOR_ABORT , q{[ABORT] } ], + [\*STDERR, \%CLI_MESSAGE_FOR_ERROR , q{[ERROR] } ], + ) { + my ($handle, $hash_ref, $prefix) = @{$_}; + if (exists($hash_ref->{$key})) { + return printf({$handle} $prefix . $hash_ref->{$key}, @args); + } + } +} + +# ------------------------------------------------------------------------------ +# Wrapper for Fcm::Interactive::get_input. +sub _cli_prompt { + my %option + = (type => 'yn', default => 'n', (ref($_[0]) ? %{shift(@_)} : ())); + my ($name, $key, @args) = @_; + return Fcm::Interactive::get_input( + title => $CLI_PROMPT_PREFIX . $name, + message => sprintf($CLI_MESSAGE_FOR_PROMPT{$key}, @args), + %option, + ); +} + +# ------------------------------------------------------------------------------ +# Check missing status and delete. +sub cm_check_missing { + my %option = %{shift()}; + my $checker + = _svn_status_checker('delete', 'MISSING', $option{st_check_handler}); + my @paths = $checker->(\@_); + if (@paths) { + run_command([qw{svn delete}, @paths]); + } +} + +# ------------------------------------------------------------------------------ +# Check unknown status and add. +sub cm_check_unknown { + my %option = %{shift()}; + my $checker + = _svn_status_checker('add', 'UNKNOWN', $option{st_check_handler}); + my @paths = $checker->(\@_); + if (@paths) { + run_command([qw{svn add}, @paths]); + } +} + +# ------------------------------------------------------------------------------ +# FCM wrapper to SVN switch. +sub cm_switch { + my %option = %{shift()}; + my ($target, $path) = @_; + $path ||= cwd(); + if (!-e $path) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path); + } + if (!is_wc($path)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); + } + + # Check for merge template in the commit log file in the working copy + my $path_of_wc = get_wct($path); + my $ci_mesg = Fcm::CmCommitMessage->new(); + $ci_mesg->dir($path_of_wc); + $ci_mesg->read_file(); + if (@{$ci_mesg->auto_mesg()}) { + return _cm_err( + Fcm::Cm::Exception->SWITCH_UNSAFE, + $path eq $path_of_wc ? $ci_mesg->base() : $ci_mesg->file(), + ); + } + + # Check for any local modifications + if (defined($option{st_check_handler})) { + my $handler = $CLI_HANDLER_OF{WC_STATUS}; + _svn_status_checker('switch', 'MODIFIED', $handler)->([$path_of_wc]); + } + + # Invokes "svn switch" + _svn( + {METHOD => 'qx', PRINT => !$option{quiet}}, + 'switch', + ($option{'non-interactive'} ? '--non-interactive' : ()), + ($option{revision} ? ('-r', $option{revision}) : ()), + ($option{quiet} ? '--quiet' : ()), + _cm_get_source( + $target, + Fcm::CmBranch->new(URL => get_url_of_wc($path_of_wc)), + )->url_peg(), + ($path_of_wc eq cwd() ? () : $path_of_wc), + ); +} + +# ------------------------------------------------------------------------------ +# FCM wrapper to SVN update. +sub cm_update { + my %option = %{shift()}; + my @targets = @_; + if (!@targets) { + @targets = (cwd()); + } + for my $target (@targets) { + if (!-e $target) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $target); + } + if (!is_wc($target)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $target); + } + $target = get_wct($target); + if ($target eq cwd()) { + $target = q{.}; + } + } + if (defined($option{st_check_handler})) { + my ($matcher_keys_ref, $show_updates) + = defined($option{revision}) ? (['MODIFIED' ], undef) + : (['MODIFIED', 'OUT_OF_DATE'], 1 ) + ; + my $matcher = sub { + for my $key (@{$matcher_keys_ref}) { + $ST_MATCHER_FOR{$key}->(@_) && return 1; + } + }; + _svn_status_checker( + 'update', $matcher, $option{st_check_handler}, $show_updates, + )->(\@targets); + } + if ($option{revision} && $option{revision} !~ $PATTERN_OF{SVN_REV}) { + $option{revision} = ( + Fcm::Keyword::expand(get_url_of_wc($targets[0]), $option{revision}) + )[1]; + } + return _svn_update(\@targets, \%option); +} + +# ------------------------------------------------------------------------------ +# Raises an abort exception. +sub _cm_abort { + my ($code) = @_; + $code ||= Fcm::Cm::Abort->USER; + die(bless({code => $code, message => 'abort'}, 'Fcm::Cm::Abort')); +} + +# ------------------------------------------------------------------------------ +# Raises a failure. +sub _cm_err { + my ($code, @targets) = @_; + die(bless( + {code => $code, message => "ERROR: $code", targets => \@targets}, + 'Fcm::Cm::Exception', + )); +} + +# ------------------------------------------------------------------------------ +# Returns the corresponding Fcm::CmBranch instance for $src_url w.r.t. $target. +sub _cm_get_source { + my ($src_url, $target) = @_; + my $source = Fcm::CmBranch->new(URL => $src_url); + if (!$source->is_url()) { + # Not a full URL, construct full URL based on current URL + $source->url_peg($target->url_peg()); + my $project = $target->project(); + my ($path) = $src_url =~ qr{\A/*(.*)\z}xms; + if (index($path, $project) == 0) { + # Argument contains the full path under the repository root + $path = substr($path, length($project)); + } + if ($path =~ $PATTERN_OF{FCM_BRANCH_PATH}) { + # Argument contains the full branch name + $path = join(q{/}, $target->project_path(), $path); + } + else { + # Argument contains the shorter branch name + $path = join(q{/}, $target->project_path(), 'branches', $path); + } + $source->path_peg($path); + } + # Replace source sub-directory with the target sub-directory + $source->subdir($target->subdir()); + # Ensure that the branch name exists + if (!$source->url_exists()) { + return _cm_err(Fcm::Cm::Exception->INVALID_URL, $src_url); + } + # Ensure that the branch name is valid + if (!$source->branch()) { + return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $src_url); + } + # Ensure that the source and target URLs are in the same project + if ($source->project_url() ne $target->project_url()) { + return _cm_err( + Fcm::Cm::Exception->DIFF_PROJECTS, + $target->url_peg(), + $source->url_peg(), + ); + } + return $source; +} + +# ------------------------------------------------------------------------------ +# Runs "svn". +sub _svn { + my @args = @_; + my %option; + if (@args && ref($args[0])) { + %option = %{shift(@args)}; + } + return run_command( + ['svn', @args], + PRINT => ($args[0] ne 'cat' && !grep {$_ eq '--xml'} @args), + %option, + ); +} + +# ------------------------------------------------------------------------------ +# Returns the results of "svn status". +sub _svn_status_get { + my ($target_list_ref, $show_updates) = @_; + my @targets = (defined($target_list_ref) ? @{$target_list_ref} : ()); + for my $target (@targets) { + if ($target eq cwd()) { + $target = q{.}; + } + } + my @options = ($show_updates ? qw{--show-updates} : ()); + return _svn({METHOD => 'qx', PRINT => 0}, 'status', @options, @targets); +} + +# ------------------------------------------------------------------------------ +# Returns a "svn status" checker. +sub _svn_status_checker { + my ($name, $matcher, $handler, $show_updates) = @_; + if (!ref($matcher)) { + $matcher = $ST_MATCHER_FOR{$matcher}; + } + return sub { + my ($target_list_ref) = @_; + my @status = _svn_status_get($target_list_ref, $show_updates); + if ($show_updates) { + @status = map {$_ =~ $PATTERN_OF{ST_AGAINST_REV} ? () : $_} @status; + } + my @status_of_interest = grep {$matcher->($_)} @status; + if (defined($handler)) { + return $handler->($name, $target_list_ref, \@status_of_interest); + } + return @status_of_interest; + } +} + +# ------------------------------------------------------------------------------ +# Runs "svn update". +sub _svn_update { + my ($target_list_ref, $option_hash_ref) = @_; + my %option = (defined($option_hash_ref) ? %{$option_hash_ref} : ()); + _svn( + {METHOD => 'qx', PRINT => !$option{quiet}}, + 'update', + ($option{'non-interactive'} ? '--non-interactive' : ()), + ($option{revision} ? ('-r', $option{revision}) : ()), + ($option{quiet} ? '--quiet' : ()), + (defined($target_list_ref) ? @{$target_list_ref} : ()), + ); +} + +# ------------------------------------------------------------------------------ +# Abort exception. +package Fcm::Cm::Abort; +use base qw{Fcm::Exception}; +use constant {FAIL => 'FAIL', NULL => 'NULL', USER => 'USER'}; + +sub get_code { + return $_[0]->{code}; +} + +# ------------------------------------------------------------------------------ +# Resource exception. +package Fcm::Cm::Exception; +our @ISA = qw{Fcm::Cm::Abort}; +use constant { + CHDIR => 'CHDIR', + INVALID_BRANCH => 'INVALID_BRANCH', + INVALID_PROJECT => 'INVALID_PROJECT', + INVALID_TARGET => 'INVALID_TARGET', + INVALID_URL => 'INVALID_URL', + INVALID_WC => 'INVALID_WC', + MERGE_REV_INVALID => 'MERGE_REV_INVALID', + MERGE_SELF => 'MERGE_SELF', + MERGE_UNRELATED => 'MERGE_UNRELATED', + MERGE_UNSAFE => 'MERGE_UNSAFE', + MKPATH => 'MKPATH', + NOT_EXIST => 'NOT_EXIST', + PARENT_NOT_EXIST => 'PARENT_NOT_EXIST', + RMTREE => 'RMTREE', + SWITCH_UNSAFE => 'SWITCH_UNSAFE', + WC_EXIST => 'WC_EXIST', + WC_INVALID_BRANCH => 'WC_INVALID_BRANCH', + WC_URL_NOT_EXIST => 'WC_URL_NOT_EXIST', +}; + +sub get_targets { + return @{$_[0]->{targets}}; +} + +1; +__END__ + +=pod + +=head1 NAME + +Fcm::Cm + +=head1 SYNOPSIS + + use Fcm::Cm qw{cli}; + + # Use as a wrapper to Subversion, and other FCM code management commands + cli('info', '--revision', 'HEAD', $url); + + use Fcm::Cm qw{cm_check_missing cm_check_unknown cm_switch cm_update}; + + # Checks status for "missing" items and "svn delete" them + $missing_st_handler = sub { + my ($name, $target_list_ref, $status_list_ref) = @_; + # ... + return @paths_of_interest; + }; + cm_check_missing({st_check_handler => $missing_st_handler}, @targets); + + # Checks status for "unknown" items and "svn add" them + $unknown_st_handler = sub { + my ($name, $target_list_ref, $status_list_ref) = @_; + # ... + return @paths_of_interest; + }; + cm_check_unknown({st_check_handler => $unknown_st_handler}, @targets); + + # Sets up a status checker + $st_check_handler = sub { + my ($name, $target_list_ref, $status_list_ref) = @_; + # ... + }; + # Switches a "working copy" at the "root" level to a new URL target + cm_switch( + { + 'non-interactive' => $non_interactive_flag, + 'quiet' => $quiet_flag, + 'revision' => $revision, + 'st_check_handler' => $st_check_handler, + }, + $target, $path_of_wc, + ); + # Runs "svn update" on each working copy from their "root" level + cm_update( + { + 'non-interactive' => $non_interactive_flag, + 'quiet' => $quiet_flag, + 'revision' => $revision, + 'st_check_handler' => $st_check_handler, + }, + @targets, + ); + +=head1 DESCRIPTION + +Wraps the Subversion client and implements other FCM code management +functionalities. + +=head1 FUNCTIONS + +=over 4 + +=item cli($function,@args) + +Implements the FCM code management CLI. If --help or -h is specified in @args, +it displays help and returns. Otherwise, it attempts to expand any FCM location +and revision keywords in @args. Calls the relevant FCM code management function +according to $function, or a SVN command if $function is not modified by FCM. + +=item cm_check_missing(\%option,@targets) + +Use "svn status" to check for missing items in @targets. If @targets is an empty +list, the function adds the current working directory to it. Expects +$option{st_check_handler} to be a CODE reference. Calls +$option{st_check_handler} with ($name, $target_list_ref, $status_list_ref) where +$name is "delete", $target_list_ref is \@targets, and $status_list_ref is an +ARRAY reference to a list of "svn status" output with the "missing" status. +$option{st_check_handler} should return a list of interesting paths, which will +be scheduled for removal using "svn delete". + +=item cm_check_unknown(\%option,@targets) + +Similar to cm_check_missing(\%option,@targets) but checks for "unknown" items, +which will be scheduled for addition using "svn add". + +=item cm_switch(\%option,$target,$path_of_wc) + +Invokes "svn switch" at the root of a working copy specified by $path_of_wc (or +the current working directory if $path_of_wc is not specified). +$option{'non-interactive'}, $option{quiet}, $option{revision} determines the +options (of the same name) that are passed to "svn switch". If +$option{st_check_handler} is set, it should be a CODE reference, and will be +called with ('switch', [$path_of_wc], $status_list_ref), where $status_list_ref +is an ARRAY reference to the output returned by "svn status" on $path_of_wc. +This can be used for the application to display the working copy status to the +user before prompting him/her to continue. The return value of +$option{st_check_handler} is ignored. + +=item cm_update(\%option,@targets) + +Invokes "svn update" at the root of each working copy specified by @targets. If +@targets is an empty list, the function adds the current working directory to +it. $option{'non-interactive'}, $option{quiet}, $option{revision} determines the +options (of the same name) that are passed to "svn update". If +$option{st_check_handler} is set, it should be a CODE reference, and will be +called with ($name, $target_list_ref, $status_list_ref), where $name is +'update', $target_list_ref is \@targets and $status_list_ref is an ARRAY +reference to the output returned by "svn status -u" on the @targets. This can be +used for the application to display the working copy update status to the user +before prompting him/her to continue. The return value of +$option{st_check_handler} is ignored. + +=back + +=head1 DIAGNOSTICS + +The following exceptions can be raised: + +=over 4 + +=item Fcm::Cm::Abort + +This exception @ISA L<Fcm::Exception|Fcm::Exception>. It is raised if a command +is aborted for some reason. The $e->get_code() method can be used to retrieve an +error code, which can be one of the following: + +=over 4 + +=item $e->FAIL + +The command aborts because of a failure. + +=item $e->NULL + +The command aborts because it will result in no change. + +=item $e->USER + +The command aborts because of an action by the user. + +=back + +=item Fcm::Cm::Exception + +This exception @ISA L<Fcm::Abort|Fcm::Abort>. It is raised if a command fails +with a known reason. The $e->get_targets() method can be used to retrieve a list +of targets/resources associated with this exception. The $e->get_code() method +can be used to retrieve an error code, which can be one of the following: + +=over 4 + +=item $e->CHDIR + +Fails to change directory to a target. + +=item $e->INVALID_BRANCH + +A target is not a valid branch URL in the standard FCM project layout. + +=item $e->INVALID_PROJECT + +A target is not a valid project URL in the standard FCM project layout. + +=item $e->INVALID_TARGET + +A target is not a valid Subversion URL or working copy. + +=item $e->INVALID_URL + +A target is not a valid Subversion URL. + +=item $e->INVALID_WC + +A target is not a valid Subversion working copy. + +=item $e->MERGE_REV_INVALID + +An invalid revision (target element 0) is specified for a merge. + +=item $e->MERGE_SELF + +Attempt to merge a URL (target element 0) to its own working copy (target +element 1). + +=item $e->MERGE_UNRELATED + +The merge target (target element 0) is not directly related to the merge source +(target element 1). + +=item $e->MERGE_UNSAFE + +A merge source (target element 0) contains changes outside the target +sub-directory. + +=item $e->MKPATH + +Fail to create a directory (target element 0) recursively. + +=item $e->NOT_EXIST + +A target does not exist. + +=item $e->PARENT_NOT_EXIST + +The parent of the target no longer exists. + +=item $e->RMTREE + +Fail to remove a directory (target element 0) recursively. + +=item $e->SWITCH_UNSAFE + +A merge template exists in the commit message file (target element 0) in a +working copy target. + +=item $e->WC_EXIST + +The target working copy already exists. + +=item $e->WC_INVALID_BRANCH + +The URL of the target working copy is not a valid branch URL in the standard FCM +project layout. + +=item $e->WC_URL_NOT_EXIST + +The URL of the target working copy no longer exists at the HEAD revision. + +=back + +=back + +=head1 TO DO + +Reintegrate with L<Fcm::CmUrl|Fcm::CmUrl> and L<Fcm::CmBranch|Fcm::CmBranch>, +but separate this module into the CLI part and the CM part. Expose the remaining +CM functions when this is done. + +Use L<SVN::Client|SVN::Client> to interface with Subversion. + +Move C<mkpatch> out of this module. + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/73c29617fe6294af862750be4d2a15a93d2c1047.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/73c29617fe6294af862750be4d2a15a93d2c1047.svn-base new file mode 100644 index 0000000..21e22a2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/73/73c29617fe6294af862750be4d2a15a93d2c1047.svn-base @@ -0,0 +1,887 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Dest +# +# DESCRIPTION +# This class contains methods to set up a destination location of an FCM +# extract/build. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use warnings; +use strict; + +package Fcm::Dest; +use base qw{Fcm::Base}; + +use Carp qw{croak} ; +use Cwd qw{cwd} ; +use Fcm::CfgLine ; +use Fcm::Timer qw{timestamp_command} ; +use Fcm::Util qw{run_command touch_file w_report}; +use File::Basename qw{basename dirname} ; +use File::Find qw{find} ; +use File::Path qw{mkpath rmtree} ; +use File::Spec ; +use Sys::Hostname qw{hostname} ; +use Text::ParseWords qw{shellwords} ; + +# Useful variables +# ------------------------------------------------------------------------------ +# List of configuration files +our @cfgfiles = ( + 'bldcfg', # default location of the build configuration file + 'extcfg', # default location of the extract configuration file +); + +# List of cache and configuration files, according to the dest type +our @cfgfiles_type = ( + 'cache', # default location of the cache file + 'cfg', # default location of the configuration file + 'parsedcfg', # default location of the as-parsed configuration file +); + +# List of lock files +our @lockfiles = ( + 'bldlock', # the build lock file + 'extlock', # the extract lock file +); + +# List of misc files +our @miscfiles_bld = ( + 'bldrunenvsh', # the build run environment shell script + 'bldmakefile', # the build Makefile +); + +# List of sub-directories created by extract +our @subdirs_ext = ( + 'cfgdir', # sub-directory for configuration files + 'srcdir', # sub-directory for source tree +); + +# List of sub-directories that can be archived by "tar" at end of build +our @subdirs_tar = ( + 'donedir', # sub-directory for "done" files + 'flagsdir', # sub-directory for "flags" files + 'incdir', # sub-directory for include files + 'ppsrcdir', # sub-directory for pre-process source tree + 'objdir', # sub-directory for object files +); + +# List of sub-directories created by build +our @subdirs_bld = ( + 'bindir', # sub-directory for executables + 'etcdir', # sub-directory for miscellaneous files + 'libdir', # sub-directory for object libraries + 'tmpdir', # sub-directory for temporary build files + @subdirs_tar, # -see above- +); + +# List of sub-directories under rootdir +our @subdirs = ( + 'cachedir', # sub-directory for caches + @subdirs_ext, # -see above- + @subdirs_bld, # -see above- +); + +# List of inherited search paths +# "rootdir" + all @subdirs, with "XXXdir" replaced with "XXXpath" +our @paths = ( + 'rootpath', + (map {my $key = $_; $key =~ s{dir\z}{path}msx; $key} @subdirs), +); + +# List of properties and their default values. +my %PROP_OF = ( + # the original destination (if current destination is a mirror) + 'dest0' => undef, + # list of inherited Fcm::Dest objects + 'inherit' => [], + # remote login name + 'logname' => scalar(getpwuid($<)), + # lock file + 'lockfile' => undef, + # remote machine + 'machine' => hostname(), + # mirror command to use + 'mirror_cmd' => 'rsync', + # (for rsync) remote mkdir, the remote shell command + 'rsh_mkdir_rsh' => 'ssh', + # (for rsync) remote mkdir, the remote shell command flags + 'rsh_mkdir_rshflags' => '-n -oBatchMode=yes', + # (for rsync) remote mkdir, the remote shell command + 'rsh_mkdir_mkdir' => 'mkdir', + # (for rsync) remote mkdir, the remote shell command flags + 'rsh_mkdir_mkdirflags' => '-p', + # (for rsync) remote mkdir, the remote shell command + 'rsync' => 'rsync', + # (for rsync) remote mkdir, the remote shell command flags + 'rsyncflags' => q{-a --exclude='.*' --delete-excluded} + . q{ --timeout=900 --rsh='ssh -oBatchMode=yes'}, + # destination root directory + 'rootdir' => undef, + # destination type, "bld" (default) or "ext" + 'type' => 'bld', +); +# Hook for property setter +my %PROP_HOOK_OF = ( + 'inherit' => \&_reset_inherit, + 'rootdir' => \&_reset_rootdir, +); + +# Mirror implementations +my %MIRROR_IMPL_OF = ( + rdist => \&_mirror_with_rdist, + rsync => \&_mirror_with_rsync, +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Dest->new(%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Dest class. See above for +# allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my ($class, %args) = @_; + my $self = bless(Fcm::Base->new(%args), $class); + while (my ($key, $value) = each(%args)) { + $key = lc($key); + if (exists($PROP_OF{$key})) { + $self->{$key} = $value; + } + } + for my $key (@subdirs, @paths, @lockfiles, @cfgfiles) { + $self->{$key} = undef; + } + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $self->DESTROY; +# +# DESCRIPTION +# This method is called automatically when the Fcm::Dest object is +# destroyed. +# ------------------------------------------------------------------------------ + +sub DESTROY { + my $self = shift; + + # Remove the lockfile if it is set + unlink $self->lockfile if $self->lockfile and -w $self->lockfile; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X($value); +# +# DESCRIPTION +# Details of these properties are explained in %PROP_OF. +# ------------------------------------------------------------------------------ + +while (my ($key, $default) = each(%PROP_OF)) { + no strict 'refs'; + *{$key} = sub { + my $self = shift(); + # Set property to specified value + if (@_) { + $self->{$key} = $_[0]; + if (exists($PROP_HOOK_OF{$key})) { + $PROP_HOOK_OF{$key}->($self, $key); + } + } + # Sets default where possible + if (!defined($self->{$key})) { + $self->{$key} = $default; + } + return $self->{$key}; + }; +} + +# Remote shell property: deprecated. +sub remote_shell { + my $self = shift(); + $self->rsh_mkdir_rsh(@_); +} + +# Resets properties associated with root directory. +sub _reset_rootdir { + my $self = shift(); + for my $key (@cfgfiles, @lockfiles, @miscfiles_bld, @subdirs) { + $self->{$key} = undef; + } +} + +# Reset properties associated with inherited paths. +sub _reset_inherit { + my $self = shift(); + for my $key (@paths) { + $self->{$key} = undef; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# +# DESCRIPTION +# This method returns X, where X is a location derived from rootdir, and can +# be one of: +# bindir, bldcfg, blddir, bldlock, bldrunenv, cache, cachedir, cfg, cfgdir, +# donedir, etcdir, extcfg, extlock, flagsdir, incdir, libdir, parsedcfg, +# ppsrcdir, objdir, or tmpdir. +# +# Details of these properties are explained earlier. +# ------------------------------------------------------------------------------ + +for my $name (@cfgfiles, @cfgfiles_type, @lockfiles, @miscfiles_bld, @subdirs) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # If variable not set, derive it from rootdir + if ($self->rootdir and not defined $self->{$name}) { + if ($name eq 'cache') { + # Cache file under root/.cache + $self->{$name} = File::Spec->catfile ( + $self->cachedir, $self->setting ('CACHE'), + ); + + } elsif ($name eq 'cfg') { + # Configuration file of current type + my $method = $self->type . 'cfg'; + $self->{$name} = $self->$method; + + } elsif (grep {$name eq $_} @cfgfiles) { + # Configuration files under the root/cfg + (my $label = uc ($name)) =~ s/CFG//; + $self->{$name} = File::Spec->catfile ( + $self->cfgdir, $self->setting ('CFG_NAME', $label), + ); + + } elsif (grep {$name eq $_} @lockfiles) { + # Lock file + $self->{$name} = File::Spec->catfile ( + $self->rootdir, $self->setting ('LOCK', uc ($name)), + ); + + } elsif (grep {$name eq $_} @miscfiles_bld) { + # Misc file + $self->{$name} = File::Spec->catfile ( + $self->rootdir, $self->setting ('BLD_MISC', uc ($name)), + ); + + } elsif ($name eq 'parsedcfg') { + # As-parsed configuration file of current type + $self->{$name} = File::Spec->catfile ( + dirname ($self->cfg), + $self->setting (qw/CFG_NAME PARSED/) . basename ($self->cfg), + ) + + } elsif (grep {$name eq $_} @subdirs) { + # Sub-directories under the root + (my $label = uc ($name)) =~ s/DIR//; + $self->{$name} = File::Spec->catfile ( + $self->rootdir, + $self->setting ('DIR', $label), + ($name eq 'cachedir' ? '.' . $self->type : ()), + ); + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# +# DESCRIPTION +# This method returns X, an array containing the search path of a destination +# directory, which can be one of: +# binpath, bldpath, cachepath, cfgpath, donepath, etcpath, flagspath, +# incpath, libpath, ppsrcpath, objpath, rootpath, srcpath, or tmppath, +# +# Details of these properties are explained earlier. +# ------------------------------------------------------------------------------ + +for my $name (@paths) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + (my $dir = $name) =~ s/path/dir/; + + if ($self->$dir and not defined $self->{$name}) { + my @path = (); + + # Recursively inherit the search path + for my $d (@{ $self->inherit }) { + unshift @path, $d->$dir; + } + + # Place the path of the current build in the front + unshift @path, $self->$dir; + + $self->{$name} = \@path; + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->archive (); +# +# DESCRIPTION +# This method creates TAR archives for selected sub-directories. +# ------------------------------------------------------------------------------ + +sub archive { + my $self = shift; + + # Save current directory + my $cwd = cwd (); + + my $tar = $self->setting (qw/OUTFILE_EXT TAR/); + my $verbose = $self->verbose; + + for my $name (@subdirs_tar) { + my $dir = $self->$name; + + # Ignore unless sub-directory exists + next unless -d $dir; + + # Change to container directory + my $base = basename ($dir); + print 'cd ', dirname ($dir), "\n" if $verbose > 2; + chdir dirname ($dir); + + # Run "tar" command + my $rc = &run_command ( + [qw/tar -czf/, $base . $tar, $base], + PRINT => $verbose > 1, ERROR => 'warn', + ); + + # Remove sub-directory + &run_command ([qw/rm -rf/, $base], PRINT => $verbose > 1) if not $rc; + } + + # Change back to "current" directory + print 'cd ', $cwd, "\n" if $verbose > 2; + chdir $cwd; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $authority = $obj->authority(); +# +# DESCRIPTION +# Returns LOGNAME@MACHINE for this destination if LOGNAME is defined and not +# the same as the user ID of the current process. Returns MACHINE if LOGNAME +# is the same as the user ID of the current process, but MACHINE is not the +# same as the current hostname. Returns an empty string if LOGNAME and +# MACHINE are not defined or are the same as in the current process. +# ------------------------------------------------------------------------------ + +sub authority { + my $self = shift; + my $return = ''; + + if ($self->logname ne $self->config->user_id) { + $return = $self->logname . '@' . $self->machine; + + } elsif ($self->machine ne &hostname()) { + $return = $self->machine; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->clean([ITEM => <list>,] [MODE => 'ALL|CONTENT|EMPTY',]); +# +# DESCRIPTION +# This method removes files/directories from the destination. If ITEM is set, +# it must be a reference to a list of method names for files/directories to +# be removed. Otherwise, the list is determined by the destination type. If +# MODE is ALL, all directories/files created by the extract/build are +# removed. If MODE is CONTENT, only contents within sub-directories are +# removed. If MODE is EMPTY (default), only empty sub-directories are +# removed. +# ------------------------------------------------------------------------------ + +sub clean { + my ($self, %args) = @_; + my $mode = exists $args{MODE} ? $args{MODE} : 'EMPTY'; + my $rc = 1; + my @names + = $args{ITEM} ? @{$args{ITEM}} + : $self->type() eq 'ext' ? ('cachedir', @subdirs_ext) + : ('cachedir', @subdirs_bld, @miscfiles_bld) + ; + my @items; + if ($mode eq 'CONTENT') { + for my $name (@names) { + my $item = $self->$name(); + push(@items, _directory_contents($item)); + } + } + else { + for my $name (@names) { + my $item = $self->$name(); + if ($mode eq 'ALL' || -d $item && !_directory_contents($item)) { + push(@items, $item); + } + } + } + for my $item (@items) { + if ($self->verbose() >= 2) { + printf("%s: remove\n", $item); + } + eval {rmtree($item)}; + if ($@) { + w_report($@); + $rc = 0; + } + } + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->create ([DIR => <dir-list>,]); +# +# DESCRIPTION +# This method creates the directories of a destination. If DIR is set, it +# must be a reference to a list of sub-directories to be created. Otherwise, +# the sub-directory list is determined by the destination type. It returns +# true if the destination is created or if it exists and is writable. +# ------------------------------------------------------------------------------ + +sub create { + my ($self, %args) = @_; + + my $rc = 1; + + my @dirs; + if (exists $args{DIR} and $args{DIR}) { + # Create only selected sub-directories + @dirs = @{ $args{DIR} }; + + } else { + # Create rootdir, cachedir and read-write sub-directories for extract/build + @dirs = ( + qw/rootdir cachedir/, + ($self->type eq 'ext' ? @subdirs_ext : @subdirs_bld), + ); + } + + for my $name (@dirs) { + my $dir = $self->$name; + + # Create directory if it does not already exist + if (not -d $dir) { + print 'Make directory: ', $dir, "\n" if $self->verbose > 1; + mkpath $dir; + } + + # Check whether directory exists and is writable + unless (-d $dir and -w $dir) { + w_report 'ERROR: ', $dir, ': cannot write to destination.'; + $rc = 0; + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->create_bldrunenvsh (); +# +# DESCRIPTION +# This method creates the runtime environment script for the build. +# ------------------------------------------------------------------------------ + +sub create_bldrunenvsh { + my $self = shift; + + # Path to executable files and directory for misc files + my @bin_paths = grep {_directory_contents($_)} @{$self->binpath()}; + my $bin_dir = -d $self->bindir() ? $self->bindir() : undef; + my $etc_dir = _directory_contents($self->etcdir()) ? $self->etcdir() : undef; + + # Create a runtime environment script if necessary + if (@bin_paths || $etc_dir) { + my $path = $self->bldrunenvsh(); + open(my $handle, '>', $path) || croak("$path: cannot open ($!)\n"); + printf($handle "#!%s\n", $self->setting(qw/TOOL SHELL/)); + if (@bin_paths) { + printf($handle "PATH=%s:\$PATH\n", join(':', @bin_paths)); + print($handle "export PATH\n"); + } + if ($etc_dir) { + printf($handle "FCM_ETCDIR=%s\n", $etc_dir); + print($handle "export FCM_ETCDIR\n"); + } + close($handle) || croak("$path: cannot close ($!)\n"); + + # Create symbolic links fcm_env.ksh and bin/fcm_env.ksh for backward + # compatibility + my $FCM_ENV_KSH = 'fcm_env.ksh'; + for my $link ( + File::Spec->catfile($self->rootdir, $FCM_ENV_KSH), + ($bin_dir ? File::Spec->catfile($bin_dir, $FCM_ENV_KSH) : ()), + ) { + if (-l $link && readlink($link) ne $path || -e $link) { + unlink($link); + } + if (!-l $link) { + symlink($path, $link) || croak("$link: cannot create symbolic link\n"); + } + } + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->dearchive (); +# +# DESCRIPTION +# This method extracts from TAR archives for selected sub-directories. +# ------------------------------------------------------------------------------ + +sub dearchive { + my $self = shift; + + my $tar = $self->setting (qw/OUTFILE_EXT TAR/); + my $verbose = $self->verbose; + + # Extract archives if necessary + for my $name (@subdirs_tar) { + my $tar_file = $self->$name . $tar; + + # Check whether tar archive exists for the named sub-directory + next unless -f $tar_file; + + # If so, extract the archive and remove it afterwards + &run_command ([qw/tar -xzf/, $tar_file], PRINT => $verbose > 1); + &run_command ([qw/rm -f/, $tar_file], PRINT => $verbose > 1); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $name = $obj->get_pkgname_of_path ($path); +# +# DESCRIPTION +# This method returns the package name of $path if $path is in (a relative +# path of) $self->srcdir, or undef otherwise. +# ------------------------------------------------------------------------------ + +sub get_pkgname_of_path { + my ($self, $path) = @_; + + my $relpath = File::Spec->abs2rel ($path, $self->srcdir); + my $name = $relpath ? [File::Spec->splitdir ($relpath)] : undef; + + return $name; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %src = $obj->get_source_files (); +# +# DESCRIPTION +# This method returns a hash (keys = package names, values = file names) +# under $self->srcdir. +# ------------------------------------------------------------------------------ + +sub get_source_files { + my $self = shift; + + my %src; + if ($self->srcdir and -d $self->srcdir) { + &find (sub { + return if /^\./; # ignore system/hidden file + return if -d $File::Find::name; # ignore directory + return if not -r $File::Find::name; # ignore unreadable files + + my $name = join ( + '__', @{ $self->get_pkgname_of_path ($File::Find::name) }, + ); + $src{$name} = $File::Find::name; + }, $self->srcdir); + } + + return \%src; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->mirror (\@items); +# +# DESCRIPTION +# This method mirrors @items (list of method names for directories or files) +# from $dest0 (which must be an instance of Fcm::Dest for a local +# destination) to this destination. +# ------------------------------------------------------------------------------ + +sub mirror { + my ($self, $items_ref) = @_; + if ($self->authority() || $self->dest0()->rootdir() ne $self->rootdir()) { + # Diagnostic + if ($self->verbose()) { + printf( + "Destination: %s\n", + ($self->authority() ? $self->authority() . q{:} : q{}) . $self->rootdir() + ); + } + if ($MIRROR_IMPL_OF{$self->mirror_cmd()}) { + $MIRROR_IMPL_OF{$self->mirror_cmd()}->($self, $self->dest0(), $items_ref); + } + else { + # Unknown mirroring tool + w_report($self->mirror_cmd, ': unknown mirroring tool, abort.'); + return 0; + } + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->_mirror_with_rdist ($dest0, \@items); +# +# DESCRIPTION +# This internal method implements $self->mirror with "rdist". +# ------------------------------------------------------------------------------ + +sub _mirror_with_rdist { + my ($self, $dest0, $items) = @_; + + my $rhost = $self->authority ? $self->authority : &hostname(); + + # Print distfile content to temporary file + my @distfile = (); + for my $label (@$items) { + push @distfile, '( ' . $dest0->$label . ' ) -> ' . $rhost . "\n"; + push @distfile, ' install ' . $self->$label . ';' . "\n"; + } + + # Set up mirroring command (use "rdist" at the moment) + my $command = 'rdist -R'; + $command .= ' -q' unless $self->verbose > 1; + $command .= ' -f - 1>/dev/null'; + + # Diagnostic + my $croak = 'Cannot execute "' . $command . '"'; + if ($self->verbose > 2) { + print timestamp_command ($command, 'Start'); + print ' ', $_ for (@distfile); + } + + # Execute the mirroring command + open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort'; + for my $line (@distfile) { + print COMMAND $line; + } + close COMMAND or croak $croak, ' (', $?, '), abort'; + + # Diagnostic + print timestamp_command ($command, 'End ') if $self->verbose > 2; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->_mirror_with_rsync($dest0, \@items); +# +# DESCRIPTION +# This internal method implements $self->mirror() with "rsync". +# ------------------------------------------------------------------------------ + +sub _mirror_with_rsync { + my ($self, $dest0, $items_ref) = @_; + my @rsh_mkdir; + if ($self->authority()) { + @rsh_mkdir = ( + $self->rsh_mkdir_rsh(), + shellwords($self->rsh_mkdir_rshflags()), + $self->authority(), + $self->rsh_mkdir_mkdir(), + shellwords($self->rsh_mkdir_mkdirflags()), + ); + } + my @rsync = ($self->rsync(), shellwords($self->rsyncflags())); + my @rsync_verbose = ($self->verbose() > 2 ? '-v' : ()); + my $auth = $self->authority() ? $self->authority() . q{:} : q{}; + for my $item (@{$items_ref}) { + # Create container directory, as rsync does not do it automatically + my $dir = dirname($self->$item()); + if (@rsh_mkdir) { + run_command([@rsh_mkdir, $dir], TIME => $self->verbose() > 2); + } + else { + mkpath($dir); + } + run_command( + [@rsync, @rsync_verbose, $dest0->$item(), $auth . $dir], + TIME => $self->verbose > 2, + ); + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->set_lock (); +# +# DESCRIPTION +# This method sets a lock in the current destination. +# ------------------------------------------------------------------------------ + +sub set_lock { + my $self = shift; + + $self->lockfile (); + + if ($self->type eq 'ext' and not $self->dest0) { + # Only set an extract lock for the local destination + $self->lockfile ($self->extlock); + + } elsif ($self->type eq 'bld') { + # Set a build lock + $self->lockfile ($self->bldlock); + } + + return &touch_file ($self->lockfile) if $self->lockfile; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines ([$index]); +# +# DESCRIPTION +# This method returns a list of configuration lines for the current +# destination. If it is set, $index is the index number of the current +# destination. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self, $index) = @_; + + my $PREFIX = $self->cfglabel($self->dest0() ? 'RDEST' : 'DEST'); + my $SUFFIX = ($index ? $Fcm::Config::DELIMITER . $index : q{}); + + my @return = ( + Fcm::CfgLine->new(label => $PREFIX . $SUFFIX, value => $self->rootdir()), + ); + if ($self->dest0()) { + for my $name (qw{ + logname + machine + mirror_cmd + rsh_mkdir_rsh + rsh_mkdir_rshflags + rsh_mkdir_mkdir + rsh_mkdir_mkdirflags + rsync + rsyncflags + }) { + if ($self->{$name} && $self->{$name} ne $PROP_OF{$name}) { # not default + push( + @return, + Fcm::CfgLine->new( + label => $PREFIX . $Fcm::Config::DELIMITER . uc($name) . $SUFFIX, + value => $self->{$name}, + ), + ); + } + } + } + + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->write_rules (); +# +# DESCRIPTION +# This method returns a string containing Makefile variable declarations for +# directories and search paths in this destination. +# ------------------------------------------------------------------------------ + +sub write_rules { + my $self = shift; + my $return = ''; + + # FCM_*DIR* + for my $i (0 .. @{ $self->inherit }) { + for my $name (@paths) { + (my $label = $name) =~ s/path$/dir/; + my $dir = $name eq 'rootpath' ? $self->$name->[$i] : File::Spec->catfile ( + '$(FCM_ROOTDIR' . ($i ? $i : '') . ')', + File::Spec->abs2rel ($self->$name->[$i], $self->rootpath->[$i]), + ); + + $return .= ($i ? '' : 'export ') . 'FCM_' . uc ($label) . ($i ? $i : '') . + ' := ' . $dir . "\n"; + } + } + + # FCM_*PATH + for my $name (@paths) { + (my $label = $name) =~ s/path$/dir/; + + $return .= 'export FCM_' . uc ($name) . ' := '; + for my $i (0 .. @{ $self->$name } - 1) { + $return .= ($i ? ':' : '') . '$(FCM_' . uc ($label) . ($i ? $i : '') . ')'; + } + $return .= "\n"; + } + + $return .= "\n"; + + return $return; +} + +# Returns contents in directory. +sub _directory_contents { + my $path = shift(); + if (!-d $path) { + return; + } + opendir(my $handle, $path) || croak("$path: cannot open directory ($!)\n"); + my @items = grep {$_ ne q{.} && $_ ne q{..}} readdir($handle); + closedir($handle); + map {File::Spec->catfile($path . $_)} @items; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/75/75b32d25f4861689b0a28426cbcee6c3085410dd.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/75/75b32d25f4861689b0a28426cbcee6c3085410dd.svn-base new file mode 100644 index 0000000..5cd78e0 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/75/75b32d25f4861689b0a28426cbcee6c3085410dd.svn-base @@ -0,0 +1,248 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive::InputGetter::GUI; +use base qw{Fcm::Interactive::InputGetter}; + +use Tk; + +################################################################################ +# Returns the geometry string for the pop up message box +sub get_geometry { + my ($self) = @_; + return $self->{geometry}; +} + +################################################################################ +# Invokes the getter +sub invoke { + my ($self) = @_; + my $answer; + local $| = 1; + + # Create a main window + my $mw = MainWindow->new(); + $mw->title($self->get_title()); + + # Define the default which applies if the dialog box is just closed or + # the user selects 'cancel' + $answer = $self->get_default() ? $self->get_default() : q{}; + + if (defined($self->get_type()) && $self->get_type() =~ qr{\A yn}ixms) { + # Create a yes-no(-all) dialog box + + # If TYPE is YNA then add a third button: 'all' + my $buttons = $self->get_type() =~ qr{a \z}ixms ? 3 : 2; + + # Message of the dialog box + $mw->Label('-text' => $self->get_message())->grid( + '-row' => 0, + '-column' => 0, + '-columnspan' => $buttons, + '-padx' => 10, + '-pady' => 10, + ); + + # The "yes" button + my $y_b = $mw->Button( + '-text' => 'Yes', + '-underline' => 0, + '-command' => sub {$answer = 'y'; $mw->destroy()}, + ) + ->grid('-row' => 1, '-column' => 0, '-padx' => 5, '-pady' => 5); + + # The "no" button + my $n_b = $mw->Button ( + '-text' => 'No', + '-underline' => 0, + '-command' => sub {$answer = 'n'; $mw->destroy()}, + ) + ->grid('-row' => 1, '-column' => 1, '-padx' => 5, '-pady' => 5); + + # The "all" button + my $a_b; + if ($buttons == 3) { + $a_b = $mw->Button( + '-text' => 'All', + '-underline' => 0, + '-command' => sub {$answer = 'a'; $mw->destroy()}, + ) + ->grid('-row' => 1, '-column' => 2, '-padx' => 5, '-pady' => 5); + } + + # Keyboard binding + if ($buttons == 3) { + $mw->bind('<Key>' => sub { + my $button + = $Tk::event->K() eq 'Y' || $Tk::event->K() eq 'y' ? $y_b + : $Tk::event->K() eq 'N' || $Tk::event->K() eq 'n' ? $n_b + : $Tk::event->K() eq 'A' || $Tk::event->K() eq 'a' ? $a_b + : undef + ; + if (defined($button)) { + $button->invoke(); + } + }); + } + else { + $mw->bind('<Key>' => sub { + my $button + = $Tk::event->K() eq 'Y' || $Tk::event->K() eq 'y' ? $y_b + : $Tk::event->K() eq 'N' || $Tk::event->K() eq 'n' ? $n_b + : undef + ; + if (defined($button)) { + $button->invoke(); + } + }); + } + + # Handle the situation when the user attempts to quit the window + $mw->protocol('WM_DELETE_WINDOW', sub { + if (self->get_default()) { + $answer = $self->get_default(); + } + $mw->destroy(); + }); + } + else { + # Create a dialog box to obtain an input string + # Message of the dialog box + $mw->Label('-text' => $self->get_message())->grid( + '-row' => 0, + '-column' => 0, + '-padx' => 5, + '-pady' => 5, + ); + + # Entry box for the user to type in the input string + my $entry = $answer; + my $input_e = $mw->Entry( + '-textvariable' => \$entry, + '-width' => 40, + ) + ->grid( + '-row' => 0, + '-column' => 1, + '-sticky' => 'ew', + '-padx' => 5, + '-pady' => 5, + ); + + my $b_f = $mw->Frame->grid( + '-row' => 1, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'e', + ); + + # An OK button to accept the input string + my $ok_b = $b_f->Button ( + '-text' => 'OK', + '-command' => sub {$answer = $entry; $mw->destroy()}, + ) + ->grid('-row' => 0, '-column' => 0, '-padx' => 5, '-pady' => 5); + + # A Cancel button to reject the input string + my $cancel_b = $b_f->Button( + '-text' => 'Cancel', + '-command' => sub {$answer = undef; $mw->destroy()}, + ) + ->grid('-row' => 0, '-column' => 1, '-padx' => 5, '-pady' => 5); + + # Keyboard binding + $mw->bind ('<Key>' => sub { + if ($Tk::event->K eq 'Return' or $Tk::event->K eq 'KP_Enter') { + $ok_b->invoke(); + } + elsif ($Tk::event->K eq 'Escape') { + $cancel_b->invoke(); + } + }); + + # Allow the entry box to expand + $mw->gridColumnconfigure(1, '-weight' => 1); + + # Set initial focus on the entry box + $input_e->focus(); + $input_e->icursor('end'); + } + + $mw->geometry($self->get_geometry()); + + # Switch on "always on top" property for $mw + $mw->property( + qw/set _NET_WM_STATE ATOM/, + 32, + ['_NET_WM_STATE_STAYS_ON_TOP'], + ($mw->toplevel()->wrapper())[0], + ); + + MainLoop(); + return $answer; +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive::InputGetter::GUI + +=head1 SYNOPSIS + + use Fcm::Interactive; + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +This is a solid implementation of +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>. It gets a user +reply from a TK pop up message box. + +=head1 METHODS + +See L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter> for a list of +inherited methods. + +=over 4 + +=item new($args_ref) + +As in L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, but also +accept a I<geometry> element for setting the geometry string of the pop up +message box. + +=item get_geometry() + +Returns the geometry string for the pop up message box. + +=back + +=head1 TO DO + +Tidy up the logic of invoke(). Separate the logic for YN/A box and string input +box, probably using a strategy pattern. Factor out the logic for the display +and the return value. + +=head1 SEE ALSO + +L<Fcm::Interactive|Fcm::Interactive>, +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, +L<Fcm::Interactive::InputGetter::CLI|Fcm::Interactive::InputGetter::CLI> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/78/7834dc53e2668261c75202c6232333cfb592637a.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/78/7834dc53e2668261c75202c6232333cfb592637a.svn-base new file mode 100644 index 0000000..cce065f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/78/7834dc53e2668261c75202c6232333cfb592637a.svn-base @@ -0,0 +1,83 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Entry; + +sub new { + my ($class, $args_ref) = @_; + if (!$args_ref) { + $args_ref = {}; + } + return bless({%{$args_ref}}, $class); +} + +################################################################################ +### Methods: get_* +for my $name ( + # Returns the key of this entry + 'key', + # Returns the value of this entry + 'value', +) { + no strict qw{refs}; + my $getter = "get_$name"; + *$getter = sub { + my ($self) = @_; + return $self->{$name}; + } +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Entry + +=head1 SYNOPSIS + + use Fcm::Keyword::Entry; + + $entry = Fcm::Keyword::Entry->new({key => $key, value => $value}); + $key = $entry->get_key(); + $value = $entry->get_value(); + +=head1 DESCRIPTION + +An object of this class represents a FCM keyword entry. + +=head1 METHODS + +=over 4 + +=item C<new({key =E<gt> $key, value =E<gt> $value})> + +Constructor. + +=item get_key() + +Returns the key of this keyword entry. + +=item get_value() + +Returns the value of this keyword entry. + +=back + +Simple formatter for displaying an entry. + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/78/784276dd8826ff1e73f65080aa42dc44e7119f12.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/78/784276dd8826ff1e73f65080aa42dc44e7119f12.svn-base new file mode 100644 index 0000000..f749f39 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/78/784276dd8826ff1e73f65080aa42dc44e7119f12.svn-base @@ -0,0 +1,154 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> + +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> + <title>Flexible Configuration Management Software License + + + + + + +

Flexible Configuration Management Software License

+ +

Please read this Software Licence as you will be bound by its terms if + you use the Software

+ +

The Licensor:

+ +

The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom

+ +

1. Licence.

+ +

The Met Office grants you a non-exclusive, royalty free; world-wide, + transferable Licence to use, modify, copy and distribute the Flexible + Configuration Management software ("the software") accompanying this License + providing:

+ +
    +
  1. you undertake to provide to the Met Office a copy of any modifications + made by you on the same terms contained within this licence agreement;
    2. + +
  2. modified files carry prominent notices stating that you changed the + files and the date of change;
    3. + +
  3. distribution of original or modified files is made free of charge under + the terms of this Licence;
    4. + +
  4. the appropriate copyright notices, the above copyright notice and a + disclaimer of warranty is included with the distribution.
    5. +
+ +

2. Ownership.

+ +

The Flexible Configuration Management software is Crown copyright and is + reproduced with the permission of Met Office under delegated authority from + the Controller of HMSO. The software and documentation are provided to you to + allow you to exercise your rights under this License, which is granted to + you.

+ +

3. Duration.

+ +

This license will remain in effect until terminated.

+ +

4. Termination.

+ +

You may terminate this license at any time by removing all copies of the + software from your system. This License will terminate immediately without + notice from us if you fail to comply with any of the provisions of this + License or in the event of your breaching the terms of this licence you are + given notice that the license has been terminated. Upon termination you will + delete all copies of the software and any related documentation.

+ +

5. Disclaimer of Warranty.

+ +
    +
  1. THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES, + INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY + AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY + REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND + PLATFORMS.
    2. + +
  2. In no event does the Met Office warrant that the software or related + documentation will satisfy your requirements, that the software and + documentation will be without errors or defects or that the operation of + the software will be uninterrupted.
    3. + +
  3. IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES, + INCLUDING BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE + SOFTWARE OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF + THE MET OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH + DAMAGES.
    4. +
+ +

6. General Provisions.

+ +
    +
  1. You will not do anything, relating to this software that will bring the + Met Office into disrepute.
    2. + +
  2. You will not use the name of the Met Office or any other contributor to + endorse or promote any products derived from the software without the + written permission of the Met Office.
    3. +
+ +

7. Acknowledgements.

+ +

The logic to extract the calling interfaces of top level subroutines and + functions from a Fortran source file is adapted from a script developed at + ECMWF and is provided by kind permission of ECMWF under the same terms of this + Licence.

+ +

8. Entire Agreement.

+ +

This License constitutes the entire agreement between us with respect to + your rights or warranties for using the software and related documentation. + If any provision of this agreement is determined to be invalid or + unenforceable the remaining provisions shall continue in full force.

+ +

9. Governing Law.

+ +

This Agreement is governed by and construed in accordance with the Laws of + England.

+ +
+ © British Crown copyright 2006-10. +
+ + diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/7d/7d07d96fb7cd1d8b8fb21cd86c4ece271d0e4f9d.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/7d/7d07d96fb7cd1d8b8fb21cd86c4ece271d0e4f9d.svn-base new file mode 100644 index 0000000..7a20ad4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/7d/7d07d96fb7cd1d8b8fb21cd86c4ece271d0e4f9d.svn-base @@ -0,0 +1,14 @@ +=head1 NAME + +fcm update (up) + +=head1 SYNOPSIS + +Bring changes from the repository into the working copy. + + usage: update [PATH...] + +Note: "fcm update" only supports --non-interactive, -r [--revision] arg and -q +[--quiet]. For detail, see the output of "L help update". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/80/80b5d03d8ae409952828a00aa8064bd15c5c1cda.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/80/80b5d03d8ae409952828a00aa8064bd15c5c1cda.svn-base new file mode 100644 index 0000000..7813cdd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/80/80b5d03d8ae409952828a00aa8064bd15c5c1cda.svn-base @@ -0,0 +1,133 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Config; + +use Fcm::CLI::Config::Default; +use List::Util qw{first}; +use Scalar::Util qw{blessed}; + +my $INSTANCE; + +################################################################################ +# Class method: returns an instance of this class +sub instance { + my ($class, $args_ref) = @_; + if ($args_ref || !$INSTANCE) { + $INSTANCE = bless({ + core_subcommands => [@Fcm::CLI::Config::Default::CORE_SUBCOMMANDS], + vc_subcommands => [@Fcm::CLI::Config::Default::VC_SUBCOMMANDS], + (defined($args_ref) ? %{$args_ref} : ()), + }, $class); + } + return $INSTANCE; +} + +################################################################################ +# Returns a subcommand matching $key +sub get_subcommand_of { + my ($self, $key) = @_; + if (blessed($key) && $key->isa('Fcm::CLI::Subcommand')) { + return first {"$_" eq "$key"} ($self->get_subcommands()); + } + else { + return first {$_->has_a_name($key)} ($self->get_subcommands()); + } +} + +################################################################################ +# Returns the subcommands +sub get_subcommands { + my ($self) = @_; + my @return = ($self->get_core_subcommands(), $self->get_vc_subcommands()); + return (wantarray() ? @return : \@return); +} + +################################################################################ +# Returns the core subcommands +sub get_core_subcommands { + my ($self) = @_; + return ( + wantarray() ? @{$self->{core_subcommands}} : $self->{core_subcommands} + ); +} + +################################################################################ +# Returns the subcommands that are relevant only with a VC system +sub get_vc_subcommands { + my ($self) = @_; + return (wantarray() ? @{$self->{vc_subcommands}} : $self->{vc_subcommands}); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Config + +=head1 SYNOPSIS + + use Fcm::CLI::Config; + $cli_config = Fcm::CLI::Config->instance(); + $subcommand = $cli_config->get_subcommand_of($key); + @subcommands = $cli_config->get_subcommands(); + @core_subcommands = $cli_config->get_core_subcommands(); + @vc_subcommands = $cli_config->get_vc_subcommands(); + +=head1 DESCRIPTION + +This class provides the configuration of the FCM command line interface. + +=head1 METHODS + +=over 4 + +=item instance($arg_ref) + +Returns an instance of this class. + +Creates the instance on first call, or replaces it with a new one if $args_ref +is defined in subsequent call. $args_ref should be a reference to a hash. The +hash can contain I and I. Each of these +settings should point to an array reference containing L +objects. If the setting is unspecified, it uses the default from +L. + +=item get_subcommand_of($key) + +Returns a L object matching the +search $key. Returns undef if there is no match. + +=item get_subcommands() + +Short-hand for: + ($self->get_core_subcommands(), $self->get_vc_subcommands()) + +=item get_core_subcommands() + +Returns the core subcommands. + +=item get_vc_subcommands() + +Returns the subcommands that are relevant only in the presence of a VC system. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/80/80db843b0048787293375744ad21f43a223e8456.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/80/80db843b0048787293375744ad21f43a223e8456.svn-base new file mode 100644 index 0000000..c477b5d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/80/80db843b0048787293375744ad21f43a223e8456.svn-base @@ -0,0 +1,615 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use Fcm::Timer qw{timestamp_command}; + +# Function declarations +sub catfile; +sub basename; +sub dirname; + +# ------------------------------------------------------------------------------ + +# Module level variables +my %unusual_tool_name = (); + +# ------------------------------------------------------------------------------ + +MAIN: { + # Name of program + my $this = basename $0; + + # Arguments + my $subcommand = shift @ARGV; + my ($function, $type) = split /:/, $subcommand; + + my ($srcpackage, $src, $target, $requirepp, @objects, @blockdata); + + if ($function eq 'archive') { + ($target, @objects) = @ARGV; + + } elsif ($function eq 'load') { + ($srcpackage, $src, $target, @blockdata) = @ARGV; + + } else { + ($srcpackage, $src, $target, $requirepp) = @ARGV; + } + + # Set up hash reference for all the required information + my %info = ( + SRCPACKAGE => $srcpackage, + SRC => $src, + TYPE => $type, + TARGET => $target, + REQUIREPP => $requirepp, + OBJECTS => \@objects, + BLOCKDATA => \@blockdata, + ); + + # Get list of unusual tools + my $i = 0; + while (my $label = &get_env ('FCM_UNUSUAL_TOOL_LABEL' . $i)) { + my $value = &get_env ('FCM_UNUSUAL_TOOL_VALUE' . $i); + $unusual_tool_name{$label} = $value; + $i++; + } + + # Invoke the action + my $rc = 0; + if ($function eq 'compile') { + $rc = &compile (\%info); + + } elsif ($function eq 'load') { + $rc = &load (\%info); + + } elsif ($function eq 'archive') { + $rc = &archive (\%info); + + } else { + print STDERR $this, ': incorrect usage, abort'; + $rc = 1; + } + + # Throw error if action failed + if ($rc) { + print STDERR $this, ' ', $function, ' failed (', $rc, ')', "\n"; + exit 1; + + } else { + exit; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &compile (\%info); +# +# DESCRIPTION +# This method invokes the correct compiler with the correct options to +# compile the source file into the required target. The argument $info is a +# hash reference set up in MAIN. The following environment variables are +# used, where * is the source file type (F for Fortran, and C for C/C++): +# +# *C - compiler command +# *C_OUTPUT - *C option to specify the name of the output file +# *C_DEFINE - *C option to declare a pre-processor def +# *C_INCLUDE - *C option to declare an include directory +# *C_MODSEARCH- *C option to declare a module search directory +# *C_COMPILE - *C option to ask the compiler to perform compile only +# *CFLAGS - *C user options +# *PPKEYS - list of pre-processor defs (may have sub-package suffix) +# FCM_VERBOSE - verbose level +# FCM_OBJDIR - destination directory of object file +# FCM_TMPDIR - temporary destination directory of object file +# ------------------------------------------------------------------------------ + +sub compile { + my $info = shift; + + # Verbose mode + my $verbose = &get_env ('FCM_VERBOSE'); + $verbose = 1 unless defined ($verbose); + + my @command = (); + + # Guess file type for backward compatibility + my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC}); + + # Compiler + push @command, &get_env ($type . 'C', 1); + + # Compile output target (typical -o option) + push @command, &get_env ($type . 'C_OUTPUT', 1), $info->{TARGET}; + + # Pre-processor definition macros + if ($info->{REQUIREPP}) { + my @ppkeys = split /\s+/, &select_flags ($info, $type . 'PPKEYS'); + my $defopt = &get_env ($type . 'C_DEFINE', 1); + + push @command, (map {$defopt . $_} @ppkeys); + } + + # Include search path + my $incopt = &get_env ($type . 'C_INCLUDE', 1); + my @incpath = split /:/, &get_env ('FCM_INCPATH'); + push @command, (map {$incopt . $_} @incpath); + + # Compiled module search path + my $modopt = &get_env ($type . 'C_MODSEARCH'); + if ($modopt) { + push @command, (map {$modopt . $_} @incpath); + } + + # Other compiler flags + my $flags = &select_flags ($info, $type . 'FLAGS'); + push @command, $flags if $flags; + + my $compile_only = &get_env ($type . 'C_COMPILE'); + if ($flags !~ /(?:^|\s)$compile_only\b/) { + push @command, &get_env ($type . 'C_COMPILE'); + } + + # Name of source file + push @command, $info->{SRC}; + + # Execute command + my $objdir = &get_env ('FCM_OBJDIR', 1); + my $tmpdir = &get_env ('FCM_TMPDIR', 1); + chdir $tmpdir; + + my $command = join ' ', @command; + if ($verbose > 1) { + print 'cd ', $tmpdir, "\n"; + print ×tamp_command ($command, 'Start'); + + } elsif ($verbose) { + print $command, "\n"; + } + + my $rc = system $command; + + print ×tamp_command ($command, 'End ') if $verbose > 1; + + # Move temporary output to correct location on success + # Otherwise, remove temporary output + if ($rc) { # error + unlink $info->{TARGET}; + + } else { # success + print 'mv ', $info->{TARGET}, ' ', $objdir, "\n" if $verbose > 1; + rename $info->{TARGET}, &catfile ($objdir, $info->{TARGET}); + } + + # Move any Fortran module definition files to the INC directory + my @modfiles = <*.mod *.MOD>; + for my $file (@modfiles) { + rename $file, &catfile ($incpath[0], $file); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &load (\%info); +# +# DESCRIPTION +# This method invokes the correct loader with the correct options to link +# the main program object into an executable. The argument $info is a hash +# reference set up in MAIN. The following environment variables are used: +# +# LD - * linker command +# LD_OUTPUT - LD option to specify the name of the output file +# LD_LIBSEARCH - LD option to declare a directory in the library search path +# LD_LIBLINK - LD option to declare an object library +# LDFLAGS - LD user options +# FCM_VERBOSE - verbose level +# FCM_LIBDIR - destination directory of object libraries +# FCM_OBJDIR - destination directory of object files +# FCM_BINDIR - destination directory of executable file +# FCM_TMPDIR - temporary destination directory of executable file +# +# * If LD is not set, it will attempt to guess the file type and use the +# compiler as the linker. +# ------------------------------------------------------------------------------ + +sub load { + my $info = shift; + + my $rc = 0; + + # Verbose mode + my $verbose = &get_env ('FCM_VERBOSE'); + $verbose = 1 unless defined ($verbose); + + # Create temporary object library + (my $name = $info->{TARGET}) =~ s/\.\S+$//; + my $libname = '__fcm__' . $name; + my $lib = 'lib' . $libname . '.a'; + my $libfile = catfile (&get_env ('FCM_LIBDIR', 1), $lib); + $rc = &archive ({TARGET => $lib}); + + unless ($rc) { + my @command = (); + + # Linker + my $ld = &select_flags ($info, 'LD'); + if (not $ld) { + # Guess file type for backward compatibility + my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC}); + $ld = &get_env ($type . 'C', 1); + } + push @command, $ld; + + # Linker output target (typical -o option) + push @command, &get_env ('LD_OUTPUT', 1), $info->{TARGET}; + + # Name of main object file + my $mainobj = (basename ($info->{SRC}) eq $info->{SRC}) + ? catfile (&get_env ('FCM_OBJDIR'), $info->{SRC}) + : $info->{SRC}; + push @command, $mainobj; + + # Link with Fortran BLOCKDATA objects if necessary + if (@{ $info->{BLOCKDATA} }) { + my @blockdata = @{ $info->{BLOCKDATA} }; + my @objpath = split /:/, &get_env ('FCM_OBJPATH'); + + # Search each BLOCKDATA object file from the object search path + for my $file (@blockdata) { + for my $dir (@objpath) { + my $full = catfile ($dir, $file); + + if (-r $full) { + $file = $full; + last; + } + } + + push @command, $file; + } + } + + # Library search path + my $libopt = &get_env ('LD_LIBSEARCH', 1); + my @libpath = split /:/, &get_env ('FCM_LIBPATH'); + push @command, (map {$libopt . $_} @libpath); + + # Link with temporary object library if it exists + push @command, &get_env ('LD_LIBLINK', 1) . $libname if -f $libfile; + + # Other linker flags + my $flags = &select_flags ($info, 'LDFLAGS'); + push @command, $flags; + + # Execute command + my $tmpdir = &get_env ('FCM_TMPDIR', 1); + my $bindir = &get_env ('FCM_BINDIR', 1); + chdir $tmpdir; + + my $command = join ' ', @command; + if ($verbose > 1) { + print 'cd ', $tmpdir, "\n"; + print ×tamp_command ($command, 'Start'); + + } elsif ($verbose) { + print $command, "\n"; + } + + $rc = system $command; + + print ×tamp_command ($command, 'End ') if $verbose > 1; + + # Move temporary output to correct location on success + # Otherwise, remove temporary output + if ($rc) { # error + unlink $info->{TARGET}; + + } else { # success + print 'mv ', $info->{TARGET}, ' ', $bindir, "\n" if $verbose > 1; + rename $info->{TARGET}, &catfile ($bindir, $info->{TARGET}); + } + } + + # Remove the temporary object library + unlink $libfile if -f $libfile; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &archive (\%info); +# +# DESCRIPTION +# This method invokes the library archiver to create an object library. The +# argument $info is a hash reference set up in MAIN. The following +# environment variables are used: +# +# AR - archiver command +# ARFLAGS - AR options to update/create an object library +# FCM_VERBOSE - verbose level +# FCM_LIBDIR - destination directory of object libraries +# FCM_OBJPATH - search path of object files +# FCM_OBJDIR - destination directory of object files +# FCM_TMPDIR - temporary destination directory of executable file +# ------------------------------------------------------------------------------ + +sub archive { + my $info = shift; + + my $rc = 0; + + # Verbose mode + my $verbose = &get_env ('FCM_VERBOSE'); + $verbose = 1 unless defined ($verbose); + + # Set up the archive command + my $lib = &basename ($info->{TARGET}); + my $tmplib = &catfile (&get_env ('FCM_TMPDIR', 1), $lib); + my @ar_cmd = (); + push @ar_cmd, (&get_env ('AR', 1), &get_env ('ARFLAGS', 1)); + push @ar_cmd, $tmplib; + + # Get object directories and their files + my %objdir; + if (exists $info->{OBJECTS}) { + # List of objects set in the argument, sort into directory/file list + for my $name (@{ $info->{OBJECTS} }) { + my $dir = (&dirname ($name) eq '.') + ? &get_env ('FCM_OBJDIR', 1) : &dirname ($name); + $objdir{$dir}{&basename ($name)} = 1; + } + + } else { + # Objects not listed in argument, search object path for all files + my @objpath = split /:/, &get_env ('FCM_OBJPATH', 1); + my %objbase = (); + + # Get registered objects into a hash (keys = objects, values = 1) + my %objects = map {($_, 1)} split (/\s+/, &get_env ('OBJECTS')); + + # Seach object path for all files + for my $dir (@objpath) { + next unless -d $dir; + + chdir $dir; + + # Use all files from each directory in the object search path + for ((glob ('*'))) { + next unless exists $objects{$_}; # consider registered objects only + $objdir{$dir}{$_} = 1 unless exists $objbase{$_}; + $objbase{$_} = 1; + } + } + } + + for my $dir (sort keys %objdir) { + next unless -d $dir; + + # Go to each object directory and executes the library archive command + chdir $dir; + my $command = join ' ', (@ar_cmd, sort keys %{ $objdir{$dir} }); + + if ($verbose > 1) { + print 'cd ', $dir, "\n"; + print ×tamp_command ($command, 'Start'); + + } else { + print $command, "\n" if exists $info->{OBJECTS}; + } + + $rc = system $command; + + print ×tamp_command ($command, 'End ') + if $verbose > 1; + last if $rc; + } + + # Move temporary output to correct location on success + # Otherwise, remove temporary output + if ($rc) { # error + unlink $tmplib; + + } else { # success + my $libdir = &get_env ('FCM_LIBDIR', 1); + + print 'mv ', $tmplib, ' ', $libdir, "\n" if $verbose > 1; + rename $tmplib, &catfile ($libdir, $lib); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $type = &guess_file_type ($filename); +# +# DESCRIPTION +# This function attempts to guess the file type by looking at the extension +# of the $filename. Only C and Fortran at the moment. +# ------------------------------------------------------------------------------ + +sub guess_file_type { + return (($_[0] =~ /\.c(\w+)?$/i) ? 'C' : 'F'); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flags = &select_flags (\%info, $set); +# +# DESCRIPTION +# This function selects the correct compiler/linker flags for the current +# sub-package from the environment variable prefix $set. The argument $info +# is a hash reference set up in MAIN. +# ------------------------------------------------------------------------------ + +sub select_flags { + my ($info, $set) = @_; + + my $srcbase = &basename ($info->{SRC}); + my @names = ($set); + push @names, split (/__/, $info->{SRCPACKAGE} . '__' . $srcbase); + + my $string = ''; + for my $i (reverse (0 .. $#names)) { + my $var = &get_env (join ('__', (@names[0 .. $i]))); + + $var = &get_env (join ('__', (@names[0 .. $i]))) + if (not defined ($var)) and $i and $names[-1] =~ s/\.[^\.]+$//; + + next unless defined $var; + $string = $var; + last; + } + + return $string; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $variable = &get_env ($name); +# $variable = &get_env ($name, $compulsory); +# +# DESCRIPTION +# This internal method gets a variable from $ENV{$name}. If $compulsory is +# set to true, it throws an error if the variable is a not set or is an empty +# string. Otherwise, it returns C if the variable is not set. +# ------------------------------------------------------------------------------ + +sub get_env { + (my $name, my $compulsory) = @_; + my $string; + + if ($name =~ /^\w+$/) { + # $name contains only word characters, variable is exported normally + die 'The environment variable "', $name, '" must be set, abort' + if $compulsory and not exists $ENV{$name}; + + $string = exists $ENV{$name} ? $ENV{$name} : undef; + + } else { + # $name contains unusual characters + die 'The environment variable "', $name, '" must be set, abort' + if $compulsory and not exists $unusual_tool_name{$name}; + + $string = exists $unusual_tool_name{$name} + ? $unusual_tool_name{$name} : undef; + } + + return $string; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = &catfile (@paths); +# +# DESCRIPTION +# This is a local implementation of what is in the File::Spec module. +# ------------------------------------------------------------------------------ + +sub catfile { + my @names = split (m!/!, join ('/', @_)); + my $path = shift @names; + + for my $name (@names) { + $path .= '/' . $name if $name; + } + + return $path; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $basename = &basename ($path); +# +# DESCRIPTION +# This is a local implementation of what is in the File::Basename module. +# ------------------------------------------------------------------------------ + +sub basename { + my $name = $_[0]; + + $name =~ s{/*$}{}; # remove trailing slashes + + if ($name =~ m#.*/([^/]+)$#) { + return $1; + + } else { + return $name; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $dirname = &dirname ($path); +# +# DESCRIPTION +# This is a local implementation of what is in the File::Basename module. +# ------------------------------------------------------------------------------ + +sub dirname { + my $name = $_[0]; + + if ($name =~ m#^/+$#) { + return '/'; # dirname of root is root + + } else { + $name =~ s{/*$}{}; # remove trailing slashes + + if ($name =~ m#^(.*)/[^/]+$#) { + my $dir = $1; + $dir =~ s{/*$}{}; # remove trailing slashes + return $dir; + + } else { + return '.'; + } + } +} + +# ------------------------------------------------------------------------------ + +__END__ + +=head1 NAME + +fcm_internal + +=head1 SYNOPSIS + + fcm_internal SUBCOMMAND ARGS + +=head1 DESCRIPTION + +The fcm_internal command is a frontend for some of the internal commands of +the FCM build system. The subcommand can be "compile", "load" or "archive" +for invoking the compiler, loader and library archiver respectively. If +"compile" or "load" is specified, it can be suffixed with ":TYPE" to +specify the nature of the source file. If TYPE is not specified, it is set +to C if the file extension begins with ".c". For all other file types, it +is set to F (for Fortran source). For compile and load, the other arguments +are 1) the name of the container package of the source file, 2) the path to +the source file and 3) the target name after compiling or loading the +source file. For compile, the 4th argument is a flag to indicate whether +pre-processing is required for compiling the source file. For load, the +4th and the rest of the arguments is a list of object files that cannot be +archived into the temporary load library and must be linked into the target +through the linker command. (E.g. Fortran BLOCKDATA program units must be +linked this way.) If archive is specified, the first argument should be the +name of the library archive target and the rest should be the object files +to be included in the archive. This command is invoked via the build system +and should never be called directly by the user. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/83/834da6daaa77c62c12273b5ec90b91118a3492ff.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/83/834da6daaa77c62c12273b5ec90b91118a3492ff.svn-base new file mode 100644 index 0000000..5cfa544 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/83/834da6daaa77c62c12273b5ec90b91118a3492ff.svn-base @@ -0,0 +1,124 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::KeywordPrinter; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::Keyword; +use Fcm::Keyword::Formatter::Entries; +use Fcm::Keyword::Formatter::Entry::Location; +use Fcm::Keyword::Exception; +use Fcm::Util qw{get_url_of_wc}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my @targets = $self->get_arguments(); + if (@targets) { + for my $target (@targets) { + my $entry_list = Fcm::Keyword::get_location_entries_for($target); + my $loc = $target; + if (-e $target) { + $loc = get_url_of_wc($target); + if (!$loc) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: unrecognised version control resource", $target, + )})); + } + } + my @entry_list = Fcm::Keyword::get_location_entries_for($loc); + if (!@entry_list) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: no FCM location keyword found for this target", $target, + )})); + } + my $formatter = Fcm::Keyword::Formatter::Entry::Location->new(); + for my $entry ( + sort {$a->get_key() cmp $b->get_key()} + grep {!$_->is_implied()} + @entry_list + ) { + print($formatter->format($entry), "\n"); + } + } + } + else { + my $formatter = Fcm::Keyword::Formatter::Entries->new(); + print($formatter->format(Fcm::Keyword::get_entries())); + } +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::KeywordPrinter + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::KeywordPrinter; + $invoker = Fcm::CLI::Invoker::KeywordPrinter->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke the location keyword printer. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the location keyword printer. If a namespace is specified in the +argument, prints revision keywords and browser mapping templates for the +specified namespace. If a namespace is not specified, prints all registered +location keywords. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if there is no matching +namespace matching that of the specified. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/83/83bb64623c9f0aca881bff62031fcf79b19ab951.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/83/83bb64623c9f0aca881bff62031fcf79b19ab951.svn-base new file mode 100644 index 0000000..d263e3f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/83/83bb64623c9f0aca881bff62031fcf79b19ab951.svn-base @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Keyword::Entry::Location; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Formatter::Entry::Location'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $formatter = $class->new(); + isa_ok($formatter, $class, $prefix); + my $entry = Fcm::Keyword::Entry::Location->new({key => 'k', value => 'v'}); + like($formatter->format($entry), qr{k \s = \s v}xms, "$prefix: format"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/84/843dbacab34956448bf05bfb327de42a07350ef9.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/84/843dbacab34956448bf05bfb327de42a07350ef9.svn-base new file mode 100644 index 0000000..d70cb91 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/84/843dbacab34956448bf05bfb327de42a07350ef9.svn-base @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Config; +use Fcm::Keyword::Entries; +use Test::More qw{no_plan}; + +my %VALUE_OF = ( + bar => { + 'bar3' => 3, + 'bar3.1' => 31, + 'bar3.14' => 314, + }, + baz => { + 'bear' => 4, + 'bee' => 6, + 'spider' => 8, + }, +); + +main(); + +sub main { + my $class = 'Fcm::Keyword::Loader::Config::Revision'; + use_ok($class); + test_constructor($class); + test_load_to($class); +} + +################################################################################ +# Tests simple usage of the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = "constructor"; + my $loader = $class->new({namespace => 'namespace'}); + isa_ok($loader, $class); + is($loader->get_namespace(), 'namespace', "$prefix: get_namespace()"); + is($loader->get_source(), 'Fcm::Config', "$prefix: get_source()"); +} + +################################################################################ +# Tests loading to an Fcm::Keyword::Entries object +sub test_load_to { + my ($class) = @_; + my $prefix = 'load to'; + my $config = Fcm::Config->instance(); + for my $key (keys(%VALUE_OF)) { + for my $rev_key (keys(%{$VALUE_OF{$key}})) { + my $value = $VALUE_OF{$key}{$rev_key}; + $config->setting(['URL_REVISION', uc($key), uc($rev_key)], $value); + } + my $entries = Fcm::Keyword::Entries->new(); + my $loader = $class->new({namespace => $key}); + isnt($loader->load_to($entries), 0, "$prefix: number loaded"); + for my $rev_key (keys(%{$VALUE_OF{$key}})) { + my $entry = $entries->get_entry_by_key($rev_key); + my $value = $VALUE_OF{$key}{$rev_key}; + if ($entry) { + is( + $entry->get_key(), + uc($rev_key), + "$prefix: by key: $rev_key", + ); + is($entry->get_value(), $value, "$prefix: by value: $rev_key"); + is( + $entries->get_entry_by_value($value), + $entry, + "$prefix: by key: $key: object", + ); + } + else { + fail("$prefix: by key: $rev_key"); + } + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/84/84f82eb5c4ec7cc7fc51f04e13bf19fa90b18537.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/84/84f82eb5c4ec7cc7fc51f04e13bf19fa90b18537.svn-base new file mode 100644 index 0000000..f6f3234 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/84/84f82eb5c4ec7cc7fc51f04e13bf19fa90b18537.svn-base @@ -0,0 +1,220 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::Help; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::CLI::Config; +use Fcm::Config; +use Fcm::Util qw{run_command}; +use IO::File; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my @subcommand_names = $self->get_arguments(); + if (@subcommand_names) { + for my $subcommand_name (@subcommand_names) { + my $help_string = $self->_get_help_for($subcommand_name); + if (!defined($help_string)) { + croak(Fcm::CLI::Exception->new({message => sprintf( + "%s: unknown command", $subcommand_name, + )})); + } + print($help_string, "\n"); + } + } + else { + print($self->_get_help()); + } +} + +################################################################################ +# Returns the help string for a subcommand matching $subcommand_name +sub _get_help_for { + my ($self, $subcommand_name) = @_; + my $subcommand + = Fcm::CLI::Config->instance()->get_subcommand_of($subcommand_name); + if (!$subcommand) { + return; + } + if ($subcommand->is_vc()) { + my $invoker = $subcommand->get_invoker($subcommand_name); + local(@ARGV) = '--help'; + $invoker->invoke(); + return q{}; + } + my $prog = Fcm::Config->instance()->setting('FCM_COMMAND'); + # FIXME: can do with using Text::Template or Perl6::Form + my $help = sprintf( + "%s %s: %s\n", + $prog, + $subcommand->as_string(), + $subcommand->get_synopsis(), + ); + $help .= sprintf( + "usage: %s %s %s\n", + $prog, $subcommand->get_names()->[0], $subcommand->get_usage(), + ); + if ($subcommand->get_description()) { + my @lines = (q{}, split("\n", $subcommand->get_description()), q{}); + $help .= join(qq{\n }, @lines) . "\n"; + } + if ($subcommand->get_options()) { + $help .= "Valid options:\n"; + my $max_length_of_name = 0; + my @option_names; + for my $option ($subcommand->get_options()) { + if (length($option->get_name()) > $max_length_of_name) { + $max_length_of_name = length($option->get_name()); + } + } + for my $option ($subcommand->get_options()) { + $help .= sprintf( + " --%s%s%s%s : %s\n", + $option->get_name(), + q{ } x ($max_length_of_name - length($option->get_name())), + ( + $option->get_letter() + ? q{ [-} . $option->get_letter() . q{]} : q{ } + ), + ($option->has_arg() ? q{ arg} : q{ } x 4), + $option->get_description(), + ); + } + } + return $help; +} + +################################################################################ +# Returns the general help string +sub _get_help { + my ($self) = @_; + my $release = $self->_get_release(); + + # FIXME: can do with using Text::Template or Perl6::Form + my $prog = Fcm::Config->instance()->setting('FCM_COMMAND'); + my $return = sprintf( + qq{usage: %s [options] [args]\n} + . qq{Flexible configuration management system, release %s.\n} + . qq{Type "%s help " for help on a specific subcommand\n} + . qq{\n} + . qq{Available subcommands:\n} + , + $prog, $release, $prog, + ); + for my $subcommand (Fcm::CLI::Config->instance()->get_core_subcommands()) { + $return .= sprintf(qq{ %s\n}, $subcommand->as_string()); + } + + my @lines = run_command( + [qw/svn help/], DEVNULL => 1, METHOD => 'qx', ERROR => 'ignore', + ); + if (@lines) { + for my $subcommand (Fcm::CLI::Config->instance()->get_vc_subcommands()) { + if (defined($subcommand->get_synopsis())) { + $return .= sprintf(qq{ %s\n}, $subcommand->as_string()); + } + else { + $return .= qq{ \n}; + } + } + $return .= "\n=> svn help\n". join(q{}, @lines); + } + return $return; +} + +################################################################################ +# Returns the release number of the current program +sub _get_release { + my ($self) = @_; + my $release = Fcm::Config->instance()->setting('FCM_RELEASE'); + my $rev_file = Fcm::Config->instance()->setting('FCM_REV_FILE'); + if (-r $rev_file) { + my $handle = IO::File->new($rev_file, 'r'); + if ($handle) { + my $rev = $handle->getline(); + $handle->close(); + chomp($rev); + if ($rev) { + $release .= qq{ (r$rev)}; + } + } + } + return $release; +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::Help + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::Help; + $invoker = Fcm::CLI::Invoker::Help->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to provide help on the command line +interface. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Provides help. If a subcommand name is specified in the argument, provides help +for the specified subcommand. If a subcommand name is not specified, provides +general CLI help. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if the specified subcommand +cannot be identified. + +=back + +=head1 TO DO + +Unit tests. + +Separate logic in this module with that of L. + +Decouples help formatter with this invoker. + +=head1 SEE ALSO + +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/85/8503bcb267b5af345e4793817ca5657fb87d3198.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/85/8503bcb267b5af345e4793817ca5657fb87d3198.svn-base new file mode 100644 index 0000000..d1c919f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/85/8503bcb267b5af345e4793817ca5657fb87d3198.svn-base @@ -0,0 +1,228 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A Fcm::Keyword::Entry sub-class for testing +{ + package TestEntry; + use base qw{Fcm::Keyword::Entry}; +} + +################################################################################ +# A mock loader implementing the Fcm::Keyword::Loader interface +{ + package MockLoader0; + use Scalar::Util qw{blessed}; + + ############################################################################ + # Constructor + sub new { + my ($class) = @_; + return bless({number_of_calls_to_load_to => 0}, $class); + } + + ############################################################################ + ##Returns the package name + sub get_source { + my ($self) = @_; + return blessed($self); + } + + ############################################################################ + # Returns number of times $self->load_to() has been called + sub get_number_of_calls_to_load_to { + my ($self) = @_; + return $self->{number_of_calls_to_load_to}; + } + + ############################################################################ + # Loads data into $entries, and returns number of entries loaded + sub load_to { + my ($self, $entries) = @_; + $self->{number_of_calls_to_load_to}++; + return $self->load_to_impl($entries); + } + + ############################################################################ + # Returns 0 + sub load_to_impl { + my ($self, $entries) = @_; + return 0; + } +} + +################################################################################ +# A mock loader implementing the Fcm::Keyword::Loader interface +{ + package MockLoader1; + our @ISA = qw{MockLoader0}; + + my %VALUE_OF = (foo => 'foo1', bar => 'bar2', baz => 'baz3'); + + ############################################################################ + # Returns a reference to the mock data + sub get_data { + my ($class) = @_; + return \%VALUE_OF; + } + + ############################################################################ + ##Writes mock data to the $entries object + sub load_to_impl { + my ($self, $entries) = @_; + my $counter = 0; + for my $key (keys(%{$self->get_data()})) { + $entries->add_entry($key, $self->get_data()->{$key}); + $counter++; + } + return $counter; + } +} + +################################################################################ +# A mock loader implementing the Fcm::Keyword::Loader interface +{ + package MockLoader2; + our @ISA = qw{MockLoader1}; + + my %VALUE_OF = (sausages => 'pig', eggs => 'hen', chips => 'potato'); + + ############################################################################ + # Returns a reference to the mock data + sub get_data { + my ($class) = @_; + return \%VALUE_OF; + } +} + +package main; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Entries'; + use_ok($class); + test_empty_constructor($class); + test_constructor($class); + test_add_entry($class); + test_loaders($class); +} + +################################################################################ +# Tests empty constructor +sub test_empty_constructor { + my ($class) = @_; + my $prefix = 'empty constructor'; + my $entries = $class->new(); + isa_ok($entries, $class); + is($entries->get_entry_class(), 'Fcm::Keyword::Entry', + "$prefix: default entry class"); + is_deeply([$entries->get_loaders()], [], "$prefix: empty list of loaders"); + is_deeply([$entries->get_all_entries()], [], + "$prefix: empty list of entries"); + for my $arg ('foo', undef) { + is($entries->get_entry_by_key($arg), undef, + "$prefix: entry by key: undef"); + is($entries->get_entry_by_value($arg), undef, + "$prefix: entry by value: undef"); + } +} + +################################################################################ +# Tests other constructor usages +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my @loaders = (MockLoader1->new(), MockLoader2->new()); + my $entries = $class->new({ + entry_class => 'not-a-class', + loaders => \@loaders, + }); + isa_ok($entries, $class); + is($entries->get_entry_class(), 'not-a-class', "$prefix: entry class"); + is_deeply([$entries->get_loaders()], \@loaders, "$prefix: list of loaders"); + eval { + $entries->add_entry('key', 'value'); + }; + isnt($@, undef, "$prefix: invalid entry class"); +} + +################################################################################ +# Tests adding entries +sub test_add_entry { + my ($class) = @_; + my $prefix = 'add entry'; + my %VALUE_OF = (key1 => 'value1', egg => 'white and yolk', 'xyz.abc' => ''); + for my $entry_class ('Fcm::Keyword::Entry', 'TestEntry') { + my $entries = $class->new({entry_class => $entry_class}); + my $number_of_entries = 0; + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->add_entry($key, $VALUE_OF{$key}); + isa_ok($entry, $entry_class); + is(scalar(@{$entries->get_all_entries()}), ++$number_of_entries, + "$prefix: number of entries: $number_of_entries"); + } + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->get_entry_by_key($key); + isa_ok($entry, $entry_class); + is($entry->get_key(), uc($key), "$prefix: get by key: $key"); + is($entry->get_value(), $VALUE_OF{$key}, + "$prefix: get by key: $key: value"); + } + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->get_entry_by_value($VALUE_OF{$key}); + isa_ok($entry, $entry_class); + is($entry->get_key(), uc($key), "$prefix: get by value: $key"); + is($entry->get_value(), $VALUE_OF{$key}, + "$prefix: get by value: $key: value"); + } + is($entries->get_entry_by_key('no-such-key'), undef, + "$prefix: get by key: no-such-key"); + is($entries->get_entry_by_value('no-such-value'), undef, + "$prefix: get by value: no-such-value"); + } +} + +################################################################################ +# Tests usage of loaders +sub test_loaders { + my ($class) = @_; + my $prefix = "loader"; + my @loaders = (MockLoader0->new(), MockLoader1->new(), MockLoader2->new()); + my $entries = $class->new({loaders => \@loaders}); + for my $loader (@loaders) { + is($loader->get_number_of_calls_to_load_to(), 0, "$prefix: not loaded"); + } + for my $key (keys(%{$loaders[1]->get_data()})) { + my $value = $loaders[1]->get_data()->{$key}; + my $entry = $entries->get_entry_by_key($key); + is($entry->get_key(), uc($key), "$prefix: by key: $key: key"); + is($entries->get_entry_by_value($value), $entry, + "$prefix: by value: $key: object"); + } + is($loaders[0]->get_number_of_calls_to_load_to(), 1, + "$prefix: loaded once: 0"); + is($loaders[1]->get_number_of_calls_to_load_to(), 1, + "$prefix: loaded once: 1"); + is($loaders[2]->get_number_of_calls_to_load_to(), 0, + "$prefix: not loaded: 2"); + for my $key (keys(%{$loaders[2]->get_data()})) { + my $value = $loaders[2]->get_data()->{$key}; + my $entry = $entries->get_entry_by_key($key); + is($entry->get_key(), uc($key), "$prefix: by key: $key: key"); + is($entries->get_entry_by_value($value), $entry, + "$prefix: by value: $key: object"); + } + is($loaders[0]->get_number_of_calls_to_load_to(), 2, + "$prefix: loaded once: 0"); + is($loaders[1]->get_number_of_calls_to_load_to(), 1, + "$prefix: loaded once: 1"); + is($loaders[2]->get_number_of_calls_to_load_to(), 1, + "$prefix: not loaded: 2"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/85/85753bf781dfa808d98538789e867e6ad9522b98.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/85/85753bf781dfa808d98538789e867e6ad9522b98.svn-base new file mode 100644 index 0000000..fd51538 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/85/85753bf781dfa808d98538789e867e6ad9522b98.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::GUI'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/8c/8cfb4b1676c2af8deb0fff1e4bec2bab93263d0c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/8c/8cfb4b1676c2af8deb0fff1e4bec2bab93263d0c.svn-base new file mode 100644 index 0000000..9dfda07 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/8c/8cfb4b1676c2af8deb0fff1e4bec2bab93263d0c.svn-base @@ -0,0 +1,103 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Loader::VC::Revision; + +use Fcm::Util qw{run_command}; + +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns the VC location where revision keywords will be loaded from +sub get_source { + my ($self) = @_; + return $self->{source}; +} + +################################################################################ +# Loads revision keywords from $self->get_source() to $entries +sub load_to { + my ($self, $entries) = @_; + my @lines = run_command( + [qw{svn pg fcm:revision}, $self->get_source()], + DEVNULL => 1, + ERROR => 'ignore', + METHOD => 'qx', + ); + my $load_counter = 0; + for my $line (@lines) { + chomp($line); + my ($key, $value) = split(qr{\s+ = \s+}xms, $line); + if ($key && $value) { + $entries->add_entry($key, $value); + $load_counter++; + } + } + return defined($load_counter); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Loader::VC::Revision + +=head1 SYNOPSIS + + $loader = Fcm::Keyword::Loader::VC::Revision->new({source => $source}); + $loader->load_to($entries); + +=head1 DESCRIPTION + +Loads revision keywords from a VC location into a +L object containing +L objects. + +=head1 METHODS + +=over 4 + +=item C $source})> + +Constructor. The argument $source is the VC location from which revision +keywords will be loaded from. + +=item get_source() + +Returns the source VC location from which revision keywords will be loaded +from. + +=item load_to($entries) + +Loads revision keywords from C<$self-Eget_source()> to $entries. + +=back + +=head1 TO DO + +Abstract away the call to the VC system, which assumes the Subversion shell +client at the moment. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/8d/8d9e3ec9272f6f47f1d978a0e1a5e90c6231fb21.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/8d/8d9e3ec9272f6f47f1d978a0e1a5e90c6231fb21.svn-base new file mode 100644 index 0000000..c845bb2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/8d/8d9e3ec9272f6f47f1d978a0e1a5e90c6231fb21.svn-base @@ -0,0 +1,94 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A sub-class of Fcm::Interactive::InputGetter for testing +{ + package TestInputGetter; + use base qw{Fcm::Interactive::InputGetter}; + + ############################################################################ + # A callback for testing + sub get_callback { + my ($self) = @_; + return $self->{callback}; + } + + ############################################################################ + # Returns some pre-defined strings + sub invoke { + my ($self) = @_; + $self->get_callback()->( + $self->get_title(), + $self->get_message(), + $self->get_type(), + $self->get_default(), + ); + return 'answer'; + } +} + +use Test::More qw{no_plan}; + +main(); + +sub main { + use_ok('Fcm::Interactive'); + test_default_impl(); + test_set_impl(); + test_get_input(); +} + +################################################################################ +# Tests default setting of input getter implementation +sub test_default_impl { + my $prefix = 'default impl'; + my ($class_name, $class_options_ref) = Fcm::Interactive::get_default_impl(); + is($class_name, 'Fcm::Interactive::InputGetter::CLI', "$prefix: class name"); + is_deeply($class_options_ref, {}, "$prefix: class options"); +} + +################################################################################ +# Tests setting the input getter implementation +sub test_set_impl { + my $prefix = 'set impl'; + my %options = (extra => 'extra-value'); + my $name = 'TestInputGetter'; + Fcm::Interactive::set_impl($name, \%options); + my ($class_name, $class_options_ref) = Fcm::Interactive::get_impl(); + is($class_name, $name, "$prefix: class name"); + is_deeply($class_options_ref, \%options, "$prefix: class options"); +} + +################################################################################ +# Tests getting input with test input getter +sub test_get_input { + my $prefix = 'get input'; + my %EXPECTED = ( + TITLE => 'title-value', + MESSAGE => 'message-value', + TYPE => 'type-value', + DEFAULT => 'default-value', + ANSWER => 'answer', + ); + Fcm::Interactive::set_impl('TestInputGetter', { + callback => sub { + my ($title, $message, $type, $default) = @_; + is($title, $EXPECTED{TITLE}, "$prefix: title"); + is($message, $EXPECTED{MESSAGE}, "$prefix: message"); + is($type, $EXPECTED{TYPE}, "$prefix: type"); + is($default, $EXPECTED{DEFAULT}, "$prefix: default"); + }, + }); + my $ans = Fcm::Interactive::get_input( + title => $EXPECTED{TITLE}, + message => $EXPECTED{MESSAGE}, + type => $EXPECTED{TYPE}, + default => $EXPECTED{DEFAULT}, + ); + is($ans, $EXPECTED{ANSWER}, "$prefix: answer"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/92/9209c140f7b19a8a3f5844e22f616f9ba09d2441.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/92/9209c140f7b19a8a3f5844e22f616f9ba09d2441.svn-base new file mode 100644 index 0000000..00a2d18 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/92/9209c140f7b19a8a3f5844e22f616f9ba09d2441.svn-base @@ -0,0 +1,71 @@ +=head1 NAME + +fcm merge + +=head1 SYNOPSIS + +Merge changes from a source into your working copy. + + 1. fcm merge SOURCE + 2. fcm merge --custom --revision N[:M] SOURCE + fcm merge --custom URL[\@REV1] URL[\@REV2] + 3. fcm merge --reverse --revision [M:]N + +=over 4 + +=item 1. + +If neither --custom nor --reverse is specified, the command merges changes +automatically from SOURCE into your working copy. SOURCE must be a valid +URL[@REV] of a branch in a standard FCM project. The base of the merge will be +calculated automatically based on the common ancestor and latest merge +information between the SOURCE and the branch of the working copy. + +=item 2. + +If --custom is specified, the command can be used in two forms. + +In the first form, it performs a custom merge from the specified changeset(s) of +SOURCE into your working copy. SOURCE must be a valid URL[@REV] of a branch in +a standard FCM project. If a single revision is specified, the merge delta is (N +- 1):N of SOURCE. Otherwise, the merge delta, is N:M of SOURCE, where N < M. + +In the second form, it performs a custom merge using the delta between the two +specified branch URLs. For each URL, if a peg revision is not specified, the +command will peg the URL with its last changed revision. + +=item 3. + +If --reverse is specified, the command performs a reverse merge of the +changeset(s) specified by the --revision option. If a single revision is +specified, the merge delta is N:(N - 1). Otherwise, the merge delta is M:N, +where M > N. Note that you do not have to specify a SOURCE for a reverse merge, +because the SOURCE should always be the branch your working copy is pointing to. + +=back + +The command provide a commit log message template following the merge. + +=head1 OPTIONS + +=over 4 + +=item --dry-run + +Try operation but make no changes. + +=item --non-interactive + +Do no interactive prompting. + +=item -r [--revision] arg + +Specify a (range of) revision number(s). + +=item --verbose + +Print extra information. + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/934655905fb67de9493fedefe7668c5bf5b9a209.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/934655905fb67de9493fedefe7668c5bf5b9a209.svn-base new file mode 100644 index 0000000..7852356 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/934655905fb67de9493fedefe7668c5bf5b9a209.svn-base @@ -0,0 +1,22 @@ +=head1 NAME + +fcm delete (del, remove, rm) + +=head1 SYNOPSIS + + fcm delete [options] [args] + +=head1 OPTIONS + +=over 4 + +=item -c [--check] + +Check for any files or directories reported by "L status" as missing +and schedule them for removal. + +=back + +For other options, see output of "L help delete". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/93d14a2d12203f1ded206906b315b2e81adcba22.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/93d14a2d12203f1ded206906b315b2e81adcba22.svn-base new file mode 100644 index 0000000..0ca0006 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/93d14a2d12203f1ded206906b315b2e81adcba22.svn-base @@ -0,0 +1,70 @@ +interface +logical function func_simple() +end function func_simple +logical function func_simple_1() +end function +logical function func_simple_2() +end +pure logical function func_simple_pure() +end function func_simple_pure +recursive pure integer function func_simple_recursive_pure(i) +integer, intent(in) :: i +end function func_simple_recursive_pure +elemental logical function func_simple_elemental() +end function func_simple_elemental +integer(selected_int_kind(0)) function func_with_use_and_args(egg, ham) +use foo +use bar, only:& + & i_am_dim +integer, intent(in) :: egg(i_am_dim) +integer, intent(in) :: ham(i_am_dim, 2) +end function func_with_use_and_args +character(20) function func_with_parameters(egg, ham) +character*(*), parameter :: x_param = '01234567890' +character(*), parameter :: & + y_param & + = '!&!&!&!&!&!' +character(len(x_param)), intent(in) :: egg +character(len(y_param)), intent(in) :: ham +end function func_with_parameters +function func_with_parameters_1(egg, ham) result(r) +integer, parameter :: x_param = 10 +integer z_param +parameter(z_param = 2) +real, intent(in), dimension(x_param) :: egg +integer, intent(in) :: ham +logical :: r(z_param) +end function func_with_parameters_1 +character(10) function func_with_contains(mushroom, tomoato) +character(5) mushroom +character(5) tomoato +end function func_with_contains +Function func_mix_local_and_result(egg, ham, bacon) Result(Breakfast) +Integer, Intent(in) :: egg, ham +Real, Intent(in) :: bacon +Real :: tomato, breakfast +End Function func_mix_local_and_result +subroutine sub_simple() +end subroutine sub_simple +subroutine sub_simple_1() +end subroutine +subroutine sub_simple_2() +end +subroutine sub_simple_3() +end sub& +&routine& +& sub_simple_3 +subroutine sub_with_contains(foo) +character*(len('!"&''&"!')) & + foo +end subroutine sub_with_contains +subroutine sub_with_renamed_import(i_am_dim) +integer, parameter :: d = 2 +complex :: i_am_dim(d) +end subroutine sub_with_renamed_import +subroutine sub_with_external(proc) +external proc +end subroutine sub_with_external +subroutine sub_with_end() +end subroutine sub_with_end +end interface diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/93ee893b44a55674f8428c61e179af89f60b693b.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/93ee893b44a55674f8428c61e179af89f60b693b.svn-base new file mode 100644 index 0000000..18f7417 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/93/93ee893b44a55674f8428c61e179af89f60b693b.svn-base @@ -0,0 +1,14 @@ +=head1 NAME + +fcm switch (sw) + +=head1 SYNOPSIS + + 1. switch URL [PATH] + 2. switch --relocate FROM TO [PATH...] + +Note: if --relocate is not specified, "fcm switch" will only support the options +--non-interactive, -r [--revision] and -q [--quiet]. For detail, see the output +of "L help switch". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/94/941867ab81b40fb1ca9a8d86c58699a5157a7dd4.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/94/941867ab81b40fb1ca9a8d86c58699a5157a7dd4.svn-base new file mode 100644 index 0000000..41da76b --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/94/941867ab81b40fb1ca9a8d86c58699a5157a7dd4.svn-base @@ -0,0 +1,1606 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Build +# +# DESCRIPTION +# This is the top level class for the FCM build system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +package Fcm::Build; +use base qw(Fcm::ConfigSystem); + +use Carp qw{croak} ; +use Cwd qw{cwd} ; +use Fcm::BuildSrc ; +use Fcm::BuildTask ; +use Fcm::Config ; +use Fcm::Dest ; +use Fcm::CfgLine ; +use Fcm::Timer qw{timestamp_command} ; +use Fcm::Util qw{expand_tilde run_command touch_file w_report}; +use File::Basename qw{dirname} ; +use File::Spec ; +use List::Util qw{first} ; +use Text::ParseWords qw{shellwords} ; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'name', # name of this build + 'target', # targets of this build +); + +# List of hash property methods for this class +my @hash_properties = ( + 'srcpkg', # source packages of this build + 'dummysrcpkg', # dummy for handling package inheritance with file extension +); + +# List of compare_setting_X methods +my @compare_setting_methods = ( + 'compare_setting_bld_blockdata', # program executable blockdata dependency + 'compare_setting_bld_dep', # custom dependency setting + 'compare_setting_bld_dep_excl', # exclude dependency setting + 'compare_setting_bld_dep_n', # no dependency check + 'compare_setting_bld_dep_pp', # custom PP dependency setting + 'compare_setting_bld_dep_exe', # program executable extra dependency + 'compare_setting_bld_exe_name', # program executable rename + 'compare_setting_bld_pp', # PP flags + 'compare_setting_infile_ext', # input file extension + 'compare_setting_outfile_ext', # output file extension + 'compare_setting_tool', # build tool settings +); + +my $DELIMITER_LIST = $Fcm::Config::DELIMITER_LIST; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Build->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Build class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::ConfigSystem->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + $self->{$_} = {} for (@hash_properties); + + bless $self, $class; + + # List of sub-methods for parse_cfg + push @{ $self->cfg_methods }, (qw/target source tool dep misc/); + + # Optional prefix in configuration declaration + $self->cfg_prefix ($self->setting (qw/CFG_LABEL BDECLARE/)); + + # System type + $self->type ('bld'); + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'target') { + # Reference to an array + $self->{$name} = []; + + } elsif ($name eq 'name') { + # Empty string + $self->{$name} = ''; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->X ($old_lines); +# +# DESCRIPTION +# This method compares current settings with those in the cache, where X is +# one of @compare_setting_methods. +# +# If setting has changed: +# * For bld_blockdata, bld_dep_ext and bld_exe_name, it sets the re-generate +# make-rule flag to true. +# * For bld_dep_excl, in a standalone build, the method will remove the +# dependency cache files for affected sub-packages. It returns an error if +# the current build inherits from previous builds. +# * For bld_pp, it updates the PP setting for affected sub-packages. +# * For infile_ext, in a standalone build, the method will remove all the +# sub-package cache files and trigger a re-build by removing most +# sub-directories created by the previous build. It returns an error if the +# current build inherits from previous builds. +# * For outfile_ext, in a standalone build, the method will remove all the +# sub-package dependency cache files. It returns an error if the current +# build inherits from previous builds. +# * For tool, it updates the "flags" files for any changed tools. +# ------------------------------------------------------------------------------ + +for my $name (@compare_setting_methods) { + no strict 'refs'; + + *$name = sub { + my ($self, $old_lines) = @_; + + (my $prefix = uc ($name)) =~ s/^COMPARE_SETTING_//; + + my ($changed, $new_lines) = + $self->compare_setting_in_config ($prefix, $old_lines); + + my $rc = scalar (keys %$changed); + + if ($rc and $old_lines) { + $self->srcpkg ('')->is_updated (1); + + if ($name =~ /^compare_setting_bld_dep(?:_excl|_n|_pp)?$/) { + # Mark affected packages as being updated + for my $key (keys %$changed) { + for my $pkg (values %{ $self->srcpkg }) { + next unless $pkg->is_in_package ($key); + $pkg->is_updated (1); + } + } + + } elsif ($name eq 'compare_setting_bld_pp') { + # Mark affected packages as being updated + for my $key (keys %$changed) { + for my $pkg (values %{ $self->srcpkg }) { + next unless $pkg->is_in_package ($key); + next unless $self->srcpkg ($key)->is_type_any ( + keys %{ $self->setting ('BLD_TYPE_DEP_PP') } + ); # Is a type requiring pre-processing + + $pkg->is_updated (1); + } + } + + } elsif ($name eq 'compare_setting_infile_ext') { + # Re-set input file type if necessary + for my $key (keys %$changed) { + for my $pkg (values %{ $self->srcpkg }) { + next unless $pkg->src and $pkg->ext and $key eq $pkg->ext; + + $pkg->type (undef); + } + } + + # Mark affected packages as being updated + for my $pkg (values %{ $self->srcpkg }) { + $pkg->is_updated (1); + } + + } elsif ($name eq 'compare_setting_outfile_ext') { + # Mark affected packages as being updated + for my $pkg (values %{ $self->srcpkg }) { + $pkg->is_updated (1); + } + + } elsif ($name eq 'compare_setting_tool') { + # Update the "flags" files for changed tools + for my $name (sort keys %$changed) { + my ($tool, @names) = split /__/, $name; + my $pkg = join ('__', @names); + my @srcpkgs = $self->srcpkg ($pkg) + ? ($self->srcpkg ($pkg)) + : @{ $self->dummysrcpkg ($pkg)->children }; + + for my $srcpkg (@srcpkgs) { + my $file = File::Spec->catfile ( + $self->dest->flagsdir, $srcpkg->flagsbase ($tool) + ); + &touch_file ($file) or croak $file, ': cannot update, abort'; + + print $file, ': updated', "\n" if $self->verbose > 2; + } + } + } + } + + return ($rc, $new_lines); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->compare_setting_dependency ($old_lines, $flag); +# +# DESCRIPTION +# This method uses the previous settings to determine the dependencies of +# current source files. +# ------------------------------------------------------------------------------ + +sub compare_setting_dependency { + my ($self, $old_lines, $flag) = @_; + + my $prefix = $flag ? 'DEP_PP' : 'DEP'; + my $method = $flag ? 'ppdep' : 'dep'; + + my $rc = 0; + my $new_lines = []; + + # Separate old lines + my %old; + if ($old_lines) { + for my $line (@$old_lines) { + next unless $line->label_starts_with ($prefix); + $old{$line->label_from_field (1)} = $line; + } + } + + # Go through each source to see if the cache is up to date + my $count = 0; + my %mtime; + for my $srcpkg (values %{ $self->srcpkg }) { + next unless $srcpkg->cursrc and $srcpkg->type; + + my $key = $srcpkg->pkgname; + my $out_of_date = $srcpkg->is_updated; + + # Check modification time of cache and source file if not out of date + if (exists $old{$key}) { + if (not $out_of_date) { + $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9] + if not exists ($mtime{$old{$key}->src}); + + $out_of_date = 1 if $mtime{$old{$key}->src} < $srcpkg->curmtime; + } + } + else { + $out_of_date = 1; + } + + if ($out_of_date) { + # Re-scan dependency + $srcpkg->is_updated(1); + my ($source_is_read, $dep_hash_ref) = $srcpkg->get_dep($flag); + if ($source_is_read) { + $count++; + } + $srcpkg->$method($dep_hash_ref); + $rc = 1; + } + else { + # Use cached dependency + my ($progname, %hash) = split ( + /$Fcm::Config::DELIMITER_PATTERN/, $old{$key}->value + ); + $srcpkg->progname ($progname) if $progname and not $flag; + $srcpkg->$method (\%hash); + } + + # New lines values: progname[::dependency-name::type][...] + my @value = ((defined $srcpkg->progname ? $srcpkg->progname : '')); + for my $name (sort keys %{ $srcpkg->$method }) { + push @value, $name, $srcpkg->$method ($name); + } + + push @$new_lines, Fcm::CfgLine->new ( + LABEL => $prefix . $Fcm::Config::DELIMITER . $key, + VALUE => join ($Fcm::Config::DELIMITER, @value), + ); + } + + print 'No. of file', ($count > 1 ? 's' : ''), ' scanned for', + ($flag ? ' PP': ''), ' dependency: ', $count, "\n" + if $self->verbose and $count; + + return ($rc, $new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->compare_setting_srcpkg ($old_lines); +# +# DESCRIPTION +# This method uses the previous settings to determine the type of current +# source files. +# ------------------------------------------------------------------------------ + +sub compare_setting_srcpkg { + my ($self, $old_lines) = @_; + + my $prefix = 'SRCPKG'; + + # Get relevant items from old lines, stripping out $prefix + my %old; + if ($old_lines) { + for my $line (@$old_lines) { + next unless $line->label_starts_with ($prefix); + $old{$line->label_from_field (1)} = $line; + } + } + + # Check for change, use previous setting if exist + my $out_of_date = 0; + my %mtime; + for my $key (keys %{ $self->srcpkg }) { + if (exists $old{$key}) { + next unless $self->srcpkg ($key)->cursrc; + + my $type = defined $self->setting ('BLD_TYPE', $key) + ? $self->setting ('BLD_TYPE', $key) : $old{$key}->value; + + $self->srcpkg ($key)->type ($type); + + if ($type ne $old{$key}->value) { + $self->srcpkg ($key)->is_updated (1); + $out_of_date = 1; + } + + if (not $self->srcpkg ($key)->is_updated) { + $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9] + if not exists ($mtime{$old{$key}->src}); + + $self->srcpkg ($key)->is_updated (1) + if $mtime{$old{$key}->src} < $self->srcpkg ($key)->curmtime; + } + + } else { + $self->srcpkg ($key)->is_updated (1); + $out_of_date = 1; + } + } + + # Check for deleted keys + for my $key (keys %old) { + next if $self->srcpkg ($key); + + $out_of_date = 1; + } + + # Return reference to an array of new lines + my $new_lines = []; + for my $key (keys %{ $self->srcpkg }) { + push @$new_lines, Fcm::CfgLine->new ( + LABEL => $prefix . $Fcm::Config::DELIMITER . $key, + VALUE => $self->srcpkg ($key)->type, + ); + } + + return ($out_of_date, $new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->compare_setting_target ($old_lines); +# +# DESCRIPTION +# This method compare the previous target settings with current ones. +# ------------------------------------------------------------------------------ + +sub compare_setting_target { + my ($self, $old_lines) = @_; + + my $prefix = 'TARGET'; + my $old; + if ($old_lines) { + for my $line (@$old_lines) { + next unless $line->label_starts_with ($prefix); + $old = $line->value; + last; + } + } + + my $new = join (' ', sort @{ $self->target }); + + return ( + (defined ($old) ? $old ne $new : 1), + [Fcm::CfgLine->new (LABEL => $prefix, VALUE => $new)], + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_fortran_interface_generator (); +# +# DESCRIPTION +# This method invokes the Fortran interface generator for all Fortran free +# format source files. It returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_fortran_interface_generator { + my $self = shift; + + my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/); + + # Set up build task to generate interface files for all selected Fortran 9x + # sources + my %task = (); + SRC_FILE: + for my $srcfile (values %{ $self->srcpkg }) { + if (!defined($srcfile->interfacebase())) { + next SRC_FILE; + } + my $target = $srcfile->interfacebase . $pdoneext; + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->donepath, + SRCFILE => $srcfile, + DEPENDENCY => [$srcfile->flagsbase ('GENINTERFACE')], + ACTIONTYPE => 'GENINTERFACE', + ); + + # Set up build tasks for each source file/package flags file for interface + # generator tool + for my $i (1 .. @{ $srcfile->pkgnames }) { + my $target = $srcfile->flagsbase ('GENINTERFACE', -$i); + my $depend = $i < @{ $srcfile->pkgnames } + ? $srcfile->flagsbase ('GENINTERFACE', -$i - 1) + : undef; + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->flagspath, + DEPENDENCY => [defined ($depend) ? $depend : ()], + ACTIONTYPE => 'UPDATE', + ) if not exists $task{$target}; + } + } + + # Set up build task to update the flags file for interface generator tool + $task{$self->srcpkg ('')->flagsbase ('GENINTERFACE')} = Fcm::BuildTask->new ( + TARGET => $self->srcpkg ('')->flagsbase ('GENINTERFACE'), + TARGETPATH => $self->dest->flagspath, + ACTIONTYPE => 'UPDATE', + ); + + my $count = 0; + + # Performs task + for my $task (values %task) { + next unless $task->actiontype eq 'GENINTERFACE'; + + my $rc = $task->action (TASKLIST => \%task); + $count++ if $rc; + } + + print 'No. of generated Fortran interface', ($count > 1 ? 's' : ''), ': ', + $count, "\n" + if $self->verbose and $count; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_make (%args); +# +# DESCRIPTION +# This method invokes the make stage of the build system. It returns true on +# success. +# +# ARGUMENTS +# ARCHIVE - If set to "true", invoke the "archive" mode. Most build files and +# directories created by this build will be archived using the +# "tar" command. If not set, the default is not to invoke the +# "archive" mode. +# JOBS - Specify number of jobs that can be handled by "make". If set, the +# value must be a natural integer. If not set, the default value is +# 1 (i.e. run "make" in serial mode). +# TARGETS - Specify targets to be built. If set, these targets will be built +# instead of the ones specified in the build configuration file. +# ------------------------------------------------------------------------------ + +sub invoke_make { + my ($self, %args) = @_; + $args{TARGETS} ||= ['all']; + $args{JOBS} ||= 1; + my @command = ( + $self->setting(qw/TOOL MAKE/), + shellwords($self->setting(qw/TOOL MAKEFLAGS/)), + # -f Makefile + ($self->setting(qw/TOOL MAKE_FILE/), $self->dest()->bldmakefile()), + # -j N + ($args{JOBS} ? ($self->setting(qw/TOOL MAKE_JOB/), $args{JOBS}) : ()), + # -s + ($self->verbose() >= 3 ? $self->setting(qw/TOOL MAKE_SILENT/) : ()), + @{$args{TARGETS}} + ); + my $old_cwd = $self->_chdir($self->dest()->rootdir()); + run_command( + \@command, ERROR => 'warn', RC => \my($code), TIME => $self->verbose() >= 3, + ); + $self->_chdir($old_cwd); + + my $rc = !$code; + if ($rc && $args{ARCHIVE}) { + $rc = $self->dest()->archive(); + } + $rc &&= $self->dest()->create_bldrunenvsh(); + while (my ($key, $source) = each(%{$self->srcpkg()})) { + $rc &&= defined($source->write_lib_dep_excl()); + } + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_pre_process (); +# +# DESCRIPTION +# This method invokes the pre-process stage of the build system. It +# returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_pre_process { + my $self = shift; + + # Check whether pre-processing is necessary + my $invoke = 0; + for (values %{ $self->srcpkg }) { + next unless $_->get_setting ('BLD_PP'); + $invoke = 1; + last; + } + return 1 unless $invoke; + + # Scan header dependency + my $rc = $self->compare_setting ( + METHOD_LIST => ['compare_setting_dependency'], + METHOD_ARGS => ['BLD_TYPE_DEP_PP'], + CACHEBASE => $self->setting ('CACHE_DEP_PP'), + ); + + return $rc if not $rc; + + my %task = (); + my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/); + + # Set up tasks for each source file + for my $srcfile (values %{ $self->srcpkg }) { + if ($srcfile->is_type_all (qw/CPP INCLUDE/)) { + # Set up a copy build task for each include file + $task{$srcfile->base} = Fcm::BuildTask->new ( + TARGET => $srcfile->base, + TARGETPATH => $self->dest->incpath, + SRCFILE => $srcfile, + DEPENDENCY => [keys %{ $srcfile->ppdep }], + ACTIONTYPE => 'COPY', + ); + + } elsif ($srcfile->lang ('TOOL_SRC_PP')) { + next unless $srcfile->get_setting ('BLD_PP'); + + # Set up a PP build task for each source file + my $target = $srcfile->base . $pdoneext; + + # Issue warning for duplicated tasks + if (exists $task{$target}) { + w_report 'WARNING: ', $target, ': unable to create task for: ', + $srcfile->src, ': task already exists for: ', + $task{$target}->srcfile->src; + next; + } + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->donepath, + SRCFILE => $srcfile, + DEPENDENCY => [$srcfile->flagsbase ('PPKEYS'), keys %{ $srcfile->ppdep }], + ACTIONTYPE => 'PP', + ); + + # Set up update ppkeys/flags build tasks for each source file/package + my $ppkeys = $self->setting ( + 'TOOL_SRC_PP', $srcfile->lang ('TOOL_SRC_PP'), 'PPKEYS' + ); + + for my $i (1 .. @{ $srcfile->pkgnames }) { + my $target = $srcfile->flagsbase ($ppkeys, -$i); + my $depend = $i < @{ $srcfile->pkgnames } + ? $srcfile->flagsbase ($ppkeys, -$i - 1) + : undef; + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->flagspath, + DEPENDENCY => [defined ($depend) ? $depend : ()], + ACTIONTYPE => 'UPDATE', + ) if not exists $task{$target}; + } + } + } + + # Set up update global ppkeys build tasks + for my $lang (keys %{ $self->setting ('TOOL_SRC_PP') }) { + my $target = $self->srcpkg ('')->flagsbase ( + $self->setting ('TOOL_SRC_PP', $lang, 'PPKEYS') + ); + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->flagspath, + ACTIONTYPE => 'UPDATE', + ); + } + + # Build all PP tasks + my $count = 0; + for my $task (values %task) { + next unless $task->actiontype eq 'PP'; + + my $rc = $task->action (TASKLIST => \%task); + $task->srcfile->is_updated ($rc); + $count++ if $rc; + } + + print 'No. of pre-processed file', ($count > 1 ? 's' : ''), ': ', $count, "\n" + if $self->verbose and $count; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_scan_dependency (); +# +# DESCRIPTION +# This method invokes the scan dependency stage of the build system. It +# returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_scan_dependency { + my $self = shift; + + # Scan/retrieve dependency + # ---------------------------------------------------------------------------- + my $rc = $self->compare_setting ( + METHOD_LIST => ['compare_setting_dependency'], + CACHEBASE => $self->setting ('CACHE_DEP'), + ); + + # Check whether make file is out of date + # ---------------------------------------------------------------------------- + my $out_of_date = not -r $self->dest->bldmakefile; + + if ($rc and not $out_of_date) { + for (qw/CACHE CACHE_DEP/) { + my $cache_mtime = (stat (File::Spec->catfile ( + $self->dest->cachedir, $self->setting ($_), + )))[9]; + my $mfile_mtime = (stat ($self->dest->bldmakefile))[9]; + + next if not defined $cache_mtime; + next if $cache_mtime < $mfile_mtime; + $out_of_date = 1; + last; + } + } + + if ($rc and not $out_of_date) { + for (values %{ $self->srcpkg }) { + next unless $_->is_updated; + $out_of_date = 1; + last; + } + } + + if ($rc and $out_of_date) { + # Write Makefile + # -------------------------------------------------------------------------- + # Register non-word package name + my $unusual = 0; + for my $key (sort keys %{ $self->srcpkg }) { + next if $self->srcpkg ($key)->src; + next if $key =~ /^\w*$/; + + $self->setting ( + ['FCM_PCK_OBJECTS', $key], 'FCM_PCK_OBJECTS' . $unusual++, + ); + } + + # Write different parts in the Makefile + my $makefile = '# Automatic Makefile' . "\n\n"; + $makefile .= 'FCM_BLD_NAME = ' . $self->name . "\n" if $self->name; + $makefile .= 'FCM_BLD_CFG = ' . $self->cfg->actual_src . "\n"; + $makefile .= 'export FCM_VERBOSE ?= ' . $self->verbose . "\n\n"; + $makefile .= $self->dest->write_rules; + $makefile .= $self->_write_makefile_perl5lib; + $makefile .= $self->_write_makefile_tool; + $makefile .= $self->_write_makefile_vpath; + $makefile .= $self->_write_makefile_target; + + # Write rules for each source package + # Ensure that container packages come before files - this allows $(OBJECTS) + # and its dependent variables to expand correctly + my @srcpkg = sort { + if ($self->srcpkg ($a)->libbase and $self->srcpkg ($b)->libbase) { + $b cmp $a; + + } elsif ($self->srcpkg ($a)->libbase) { + -1; + + } elsif ($self->srcpkg ($b)->libbase) { + 1; + + } else { + $a cmp $b; + } + } keys %{ $self->srcpkg }; + + for (@srcpkg) { + $makefile .= $self->srcpkg ($_)->write_rules if $self->srcpkg ($_)->rules; + } + $makefile .= '# EOF' . "\n"; + + # Update Makefile + open OUT, '>', $self->dest->bldmakefile + or croak $self->dest->bldmakefile, ': cannot open (', $!, '), abort'; + print OUT $makefile; + close OUT + or croak $self->dest->bldmakefile, ': cannot close (', $!, '), abort'; + + print $self->dest->bldmakefile, ': updated', "\n" if $self->verbose; + + # Check for duplicated targets + # -------------------------------------------------------------------------- + # Get list of types that cannot have duplicated targets + my @no_duplicated_target_types = split ( + /$DELIMITER_LIST/, + $self->setting ('BLD_TYPE_NO_DUPLICATED_TARGET'), + ); + + my %targets; + for my $name (sort keys %{ $self->srcpkg }) { + next unless $self->srcpkg ($name)->rules; + + for my $key (sort keys %{ $self->srcpkg ($name)->rules }) { + if (exists $targets{$key}) { + # Duplicated target: warning for most file types + my $status = 'WARNING'; + + # Duplicated target: error for the following file types + if (@no_duplicated_target_types and + $self-srcpkg ($name)->is_type_any (@no_duplicated_target_types) and + $targets{$key}->is_type_any (@no_duplicated_target_types)) { + $status = 'ERROR'; + $rc = 0; + } + + # Report the warning/error + w_report $status, ': ', $key, ': duplicated targets for building:'; + w_report ' ', $targets{$key}->src; + w_report ' ', $self->srcpkg ($name)->src; + + } else { + $targets{$key} = $self->srcpkg ($name); + } + } + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_setup_build (); +# +# DESCRIPTION +# This method invokes the setup_build stage of the build system. It returns +# true on success. +# ------------------------------------------------------------------------------ + +sub invoke_setup_build { + my $self = shift; + + my $rc = 1; + + # Extract archived sub-directories if necessary + $rc = $self->dest->dearchive if $rc; + + # Compare cache + $rc = $self->compare_setting (METHOD_LIST => [ + 'compare_setting_target', # targets + 'compare_setting_srcpkg', # source package type + @compare_setting_methods, + ]) if $rc; + + # Set up runtime dependency scan patterns + my %dep_pattern = %{ $self->setting ('BLD_DEP_PATTERN') }; + for my $key (keys %dep_pattern) { + my $pattern = $dep_pattern{$key}; + + while ($pattern =~ /##([\w:]+)##/g) { + my $match = $1; + my $val = $self->setting (split (/$Fcm::Config::DELIMITER/, $match)); + + last unless defined $val; + $val =~ s/\./\\./; + + $pattern =~ s/##$match##/$val/; + } + + $self->setting (['BLD_DEP_PATTERN', $key], $pattern) + unless $pattern eq $dep_pattern{$key}; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_system (%args); +# +# DESCRIPTION +# This method invokes the build system. It returns true on success. See also +# the header for invoke_make for further information on arguments. +# +# ARGUMENTS +# STAGE - If set, it should be an integer number or a recognised keyword or +# abbreviation. If set, the build is performed up to the named stage. +# If not set, the default is to perform all stages of the build. +# Allowed values are: +# 1, setup or s +# 2, pre_process or pp +# 3, generate_dependency or gd +# 4, generate_interface or gi +# 5, all, a, make or m +# ------------------------------------------------------------------------------ + +sub invoke_system { + my $self = shift; + my %args = @_; + + # Parse arguments + # ---------------------------------------------------------------------------- + # Default: run all 5 stages + my $stage = (exists $args{STAGE} and $args{STAGE}) ? $args{STAGE} : 5; + + # Resolve named stages + if ($stage !~ /^\d$/) { + my %stagenames = ( + 'S(?:ETUP)?' => 1, + 'P(?:RE)?_?P(?:ROCESS)?' => 2, + 'G(?:ENERATE)?_?D(?:ENPENDENCY)?' => 3, + 'G(?:ENERATE)?_?I(?:NTERFACE)?' => 4, + '(?:A(?:LL)|M(?:AKE)?)' => 5, + ); + + # Does it match a recognised stage? + for my $name (keys %stagenames) { + next unless $stage =~ /$name/i; + + $stage = $stagenames{$name}; + last; + } + + # Specified stage name not recognised, default to 5 + if ($stage !~ /^\d$/) { + w_report 'WARNING: ', $stage, ': invalid build stage, default to 5.'; + $stage = 5; + } + } + + # Run the method associated with each stage + # ---------------------------------------------------------------------------- + my $rc = 1; + + my @stages = ( + ['Setup build' , 'invoke_setup_build'], + ['Pre-process' , 'invoke_pre_process'], + ['Scan dependency' , 'invoke_scan_dependency'], + ['Generate Fortran interface', 'invoke_fortran_interface_generator'], + ['Make' , 'invoke_make'], + ); + + for my $i (1 .. 5) { + last if (not $rc) or $i > $stage; + + my ($name, $method) = @{ $stages[$i - 1] }; + $rc = $self->invoke_stage ($name, $method, %args) if $rc and $stage >= $i; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_dep (\@cfg_lines); +# +# DESCRIPTION +# This method parses the dependency settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_dep { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + + # EXCL_DEP, EXE_DEP and BLOCKDATA declarations + # ---------------------------------------------------------------------------- + for my $name (qw/BLD_BLOCKDATA BLD_DEP BLD_DEP_EXCL BLD_DEP_EXE/) { + for my $line (grep {$_->slabel_starts_with_cfg ($name)} @$cfg_lines) { + # Separate label into a list, delimited by double-colon, remove 1st field + my @flds = $line->slabel_fields; + shift @flds; + + if ($name =~ /^(?:BLD_DEP|BLD_DEP_EXCL|BLD_DEP_PP)$/) { + # BLD_DEP_*: label fields may contain sub-package + my $pk = @flds ? join ('__', @flds) : ''; + + # Check whether sub-package is valid + if ($pk and not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) { + $line->error ($line->label . ': invalid sub-package in declaration.'); + $rc = 0; + next; + } + + # Setting is stored in an array reference + $self->setting ([$name, $pk], []) + if not defined $self->setting ($name, $pk); + + # Add current declaration to the array if necessary + my $list = $self->setting ($name, $pk); + my $value = $name eq 'BLD_DEP_EXCL' ? uc ($line->value) : $line->value; + push @$list, $value if not grep {$_ eq $value} @$list; + + } else { + # EXE_DEP and BLOCKDATA: label field may be an executable target + my $target = @flds ? $flds[0] : ''; + + # The value contains a list of objects and/or sub-package names + my @deps = split /\s+/, $line->value; + + if (not @deps) { + if ($name eq 'BLD_BLOCKDATA') { + # The objects containing a BLOCKDATA program unit must be declared + $line->error ($line->label . ': value not set.'); + $rc = 0; + next; + + } else { + # If $value is a null string, target(s) depends on all objects + push @deps, ''; + } + } + + for my $dep (@deps) { + $dep =~ s/$Fcm::Config::DELIMITER_PATTERN/__/g; + } + + $self->setting ([$name, $target], join (' ', sort @deps)); + } + + $line->parsed (1); + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_dest (\@cfg_lines); +# +# DESCRIPTION +# This method parses the build destination settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_dest { + my ($self, $cfg_lines) = @_; + + my $rc = $self->SUPER::parse_cfg_dest ($cfg_lines); + + # Set up search paths + for my $name (@Fcm::Dest::paths) { + (my $label = uc ($name)) =~ s/PATH//; + + $self->setting (['PATH', $label], $self->dest->$name); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_misc (\@cfg_lines); +# +# DESCRIPTION +# This method parses misc build settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_misc { + my ($self, $cfg_lines_ref) = @_; + my $rc = 1; + my %item_of = ( + BLD_DEP_N => [\&_parse_cfg_misc_dep_n , 1 ], # boolean + BLD_EXE_NAME => [\&_parse_cfg_misc_exe_name ], + BLD_LIB => [\&_parse_cfg_misc_dep_n ], + BLD_PP => [\&_parse_cfg_misc_dep_n , 1 ], # boolean + BLD_TYPE => [\&_parse_cfg_misc_dep_n ], + INFILE_EXT => [\&_parse_cfg_misc_file_ext, 0, 1], # uc($value) + OUTFILE_EXT => [\&_parse_cfg_misc_file_ext, 1, 0], # uc($ns) + ); + while (my ($key, $item) = each(%item_of)) { + my ($handler, @extra_arguments) = @{$item}; + for my $line (@{$cfg_lines_ref}) { + if ($line->slabel_starts_with_cfg($key)) { + if ($handler->($self, $key, $line, @extra_arguments)) { + $line->parsed(1); + } + else { + $rc = 0; + } + } + } + } + return $rc; +} + +# ------------------------------------------------------------------------------ +# parse_cfg_misc: handler of BLD_EXE_NAME or similar. +sub _parse_cfg_misc_exe_name { + my ($self, $key, $line) = @_; + my ($prefix, $name, @fields) = $line->slabel_fields(); + if (!$name || @fields) { + $line->error(sprintf('%s: expects a single label name field.', $key)); + return 0; + } + $self->setting([$key, $name], $line->value()); + return 1; +} + +# ------------------------------------------------------------------------------ +# parse_cfg_misc: handler of BLD_DEP_N or similar. +sub _parse_cfg_misc_dep_n { + my ($self, $key, $line, $value_is_boolean) = @_; + my ($prefix, @fields) = $line->slabel_fields(); + my $ns = @fields ? join(q{__}, @fields) : q{}; + if ($ns && !$self->srcpkg($ns) && !$self->dummysrcpkg($ns)) { + $line->error($line->label() . ': invalid sub-package in declaration.'); + return 0; + } + my @srcpkgs + = $self->dummysrcpkg($ns) ? @{$self->dummysrcpkg($ns)->children()} + : $self->srcpkg($ns) + ; + my $value = $value_is_boolean ? $line->bvalue() : $line->value(); + for my $srcpkg (@srcpkgs) { + $self->setting([$key, $srcpkg->pkgname()], $value); + } + return 1; +} + +# ------------------------------------------------------------------------------ +# parse_cfg_misc: handler of INFILE_EXT/OUTFILE_EXT or similar. +sub _parse_cfg_misc_file_ext { + my ($self, $key, $line, $ns_in_uc, $value_in_uc) = @_; + my ($prefix, $ns) = $line->slabel_fields(); + my $value = $value_in_uc ? uc($line->value()) : $line->value(); + $self->setting([$key, ($ns_in_uc ? uc($ns) : $ns)], $value); + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_source (\@cfg_lines); +# +# DESCRIPTION +# This method parses the source package settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_source { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + my %src = (); + + # Automatic source directory search? + # ---------------------------------------------------------------------------- + my $search = 1; + + for my $line (grep {$_->slabel_starts_with_cfg ('SEARCH_SRC')} @$cfg_lines) { + $search = $line->bvalue; + $line->parsed (1); + } + + # Search src/ sub-directory if necessary + %src = %{ $self->dest->get_source_files } if $search; + + # SRC declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('FILE')} @$cfg_lines) { + # Expand ~ notation and path relative to srcdir of destination + my $value = $line->value; + $value = File::Spec->rel2abs (&expand_tilde ($value), $self->dest->srcdir); + + if (not -r $value) { + $line->error ($value . ': source does not exist or is not readable.'); + next; + } + + # Package name + my @names = $line->slabel_fields; + shift @names; + + # If package name not set, determine using the path if possible + if (not @names) { + my $package = $self->dest->get_pkgname_of_path ($value); + @names = @$package if defined $package; + } + + if (not @names) { + $line->error ($self->cfglabel ('FILE') . + ': package not specified/cannot be determined.'); + next; + } + + $src{join ('__', @names)} = $value; + + $line->parsed (1); + } + + # For directories, get non-recursive file listing, and add to %src + # ---------------------------------------------------------------------------- + for my $key (keys %src) { + next unless -d $src{$key}; + + opendir DIR, $src{$key} or die $src{$key}, ': cannot read directory'; + while (my $base = readdir 'DIR') { + next if $base =~ /^\./; + + my $file = File::Spec->catfile ($src{$key}, $base); + next unless -f $file and -r $file; + + my $name = join ('__', ($key, $base)); + $src{$name} = $file unless exists $src{$name}; + } + closedir DIR; + + delete $src{$key}; + } + + # Set up source packages + # ---------------------------------------------------------------------------- + my %pkg = (); + for my $name (keys %src) { + $pkg{$name} = Fcm::BuildSrc->new (PKGNAME => $name, SRC => $src{$name}); + } + + # INHERIT::SRC declarations + # ---------------------------------------------------------------------------- + my %can_inherit = (); + for my $line ( + grep {$_->slabel_starts_with_cfg(qw/INHERIT FILE/)} @{$cfg_lines} + ) { + my ($key1, $key2, @ns) = $line->slabel_fields(); + $can_inherit{join('__', @ns)} = $line->bvalue(); + $line->parsed(1); + } + + # Inherit packages, if it is OK to do so + for my $inherited_build (reverse(@{$self->inherit()})) { + SRCPKG: + while (my ($key, $srcpkg) = each(%{$inherited_build->srcpkg()})) { + if (exists($pkg{$key}) || !$srcpkg->src()) { + next SRCPKG; + } + my $known_key = first {exists($can_inherit{$_})} @{$srcpkg->pkgnames()}; + if (defined($known_key) && !$can_inherit{$known_key}) { + next SRCPKG; + } + $pkg{$key} = $srcpkg; + } + } + + # Get list of intermediate "packages" + # ---------------------------------------------------------------------------- + for my $name (keys %pkg) { + # Name of current package + my @names = split /__/, $name; + + my $cur = $name; + + while ($cur) { + # Name of parent package + pop @names; + my $parent = @names ? join ('__', @names) : ''; + + # If parent package does not exist, create it + $pkg{$parent} = Fcm::BuildSrc->new (PKGNAME => $parent) + unless exists $pkg{$parent}; + + # Current package is a child of the parent package + push @{ $pkg{$parent}->children }, $pkg{$cur} + unless grep {$_->pkgname eq $cur} @{ $pkg{$parent}->children }; + + # Go up a package + $cur = $parent; + } + } + + $self->srcpkg (\%pkg); + + # Dummy: e.g. "foo/bar/baz.egg" belongs to the "foo/bar/baz" dummy. + # ---------------------------------------------------------------------------- + for my $name (keys %pkg) { + (my $dname = $name) =~ s/\.\w+$//; + next if $dname eq $name; + next if $self->srcpkg ($dname); + + $self->dummysrcpkg ($dname, Fcm::BuildSrc->new (PKGNAME => $dname)) + unless $self->dummysrcpkg ($dname); + push @{ $self->dummysrcpkg ($dname)->children }, $pkg{$name}; + } + + # Make sure a package is defined + # ---------------------------------------------------------------------------- + if (not %{$self->srcpkg}) { + w_report 'ERROR: ', $self->cfg->actual_src, ': no source file to build.'; + $rc = 0; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_target (\@cfg_lines); +# +# DESCRIPTION +# This method parses the target settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_target { + my ($self, $cfg_lines) = @_; + + # NAME declaraions + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('NAME')} @$cfg_lines) { + $self->name ($line->value); + $line->parsed (1); + } + + # TARGET declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('TARGET')} @$cfg_lines) { + # Value is a space delimited list + push @{ $self->target }, split (/\s+/, $line->value); + $line->parsed (1); + } + + # INHERIT::TARGET declarations + # ---------------------------------------------------------------------------- + # By default, do not inherit target + my $inherit_flag = 0; + + for (grep {$_->slabel_starts_with_cfg (qw/INHERIT TARGET/)} @$cfg_lines) { + $inherit_flag = $_->bvalue; + $_->parsed (1); + } + + # Inherit targets from inherited build, if $inherit_flag is set to true + # ---------------------------------------------------------------------------- + if ($inherit_flag) { + for my $use (reverse @{ $self->inherit }) { + unshift @{ $self->target }, @{ $use->target }; + } + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_tool (\@cfg_lines); +# +# DESCRIPTION +# This method parses the tool settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_tool { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + + my %tools = %{ $self->setting ('TOOL') }; + my @package_tools = split(/$DELIMITER_LIST/, $self->setting('TOOL_PACKAGE')); + + # TOOL declaration + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('TOOL')} @$cfg_lines) { + # Separate label into a list, delimited by double-colon, remove TOOL + my @flds = $line->slabel_fields; + shift @flds; + + # Check that there is a field after TOOL + if (not @flds) { + $line->error ('TOOL: not followed by a valid label.'); + $rc = 0; + next; + } + + # The first field is the tool iteself, identified in uppercase + $flds[0] = uc ($flds[0]); + + # Check that the tool is recognised + if (not exists $tools{$flds[0]}) { + $line->error ($flds[0] . ': not a valid TOOL.'); + $rc = 0; + next; + } + + # Check sub-package declaration + if (@flds > 1 and not grep {$_ eq $flds[0]} @package_tools) { + $line->error ($flds[0] . ': sub-package not accepted with this TOOL.'); + $rc = 0; + next; + } + + # Name of declared package + my $pk = join ('__', @flds[1 .. $#flds]); + + # Check whether package exists + if (not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) { + $line->error ($line->label . ': invalid sub-package in declaration.'); + $rc = 0; + next; + } + + $self->setting (['TOOL', join ('__', @flds)], $line->value); + $line->parsed (1); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_perl5lib (); +# +# DESCRIPTION +# This method returns a makefile $string for defining $PERL5LIB. +# ------------------------------------------------------------------------------ + +sub _write_makefile_perl5lib { + my $self = shift; + + my $classpath = File::Spec->catfile (split (/::/, ref ($self))) . '.pm'; + + my $libdir = dirname (dirname ($INC{$classpath})); + my @libpath = split (/:/, (exists $ENV{PERL5LIB} ? $ENV{PERL5LIB} : '')); + + my $string = ((grep {$_ eq $libdir} @libpath) + ? '' + : 'export PERL5LIB := ' . $libdir . + (exists $ENV{PERL5LIB} ? ':$(PERL5LIB)' : '') . "\n\n"); + + return $string; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_target (); +# +# DESCRIPTION +# This method returns a makefile $string for defining the default targets. +# ------------------------------------------------------------------------------ + +sub _write_makefile_target { + my $self = shift; + + # Targets of the build + # ---------------------------------------------------------------------------- + my @targets = @{ $self->target }; + if (not @targets) { + # Build targets not specified by user, default to building all main programs + my @programs = (); + + # Get all main programs from all packages + for my $pkg (values %{ $self->srcpkg }) { + push @programs, $pkg->exebase if $pkg->exebase; + } + + @programs = sort (@programs); + + if (@programs) { + # Build main programs, if there are any + @targets = @programs; + + } else { + # No main program in source tree, build the default library + @targets = ($self->srcpkg ('')->libbase); + } + } + + my $return = 'FCM_BLD_TARGETS = ' . join (' ', @targets) . "\n\n"; + + # Default targets + $return .= '.PHONY : all' . "\n\n"; + $return .= 'all : $(FCM_BLD_TARGETS)' . "\n\n"; + + # Targets for copy dummy + $return .= sprintf("%s:\n\ttouch \$@\n\n", $self->setting(qw/BLD_CPDUMMY/)); + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_tool (); +# +# DESCRIPTION +# This method returns a makefile $string for defining the build tools. +# ------------------------------------------------------------------------------ + +sub _write_makefile_tool { + my $self = shift; + + # List of build tools + my $tool = $self->setting ('TOOL'); + + # List of tools local to FCM, (will not be exported) + my %localtool = map {($_, 1)} split ( # map into a hash table + /$DELIMITER_LIST/, $self->setting ('TOOL_LOCAL'), + ); + + # Export required tools + my $count = 0; + my $return = ''; + for my $name (sort keys %$tool) { + # Ignore local tools + next if exists $localtool{(split (/__/, $name))[0]}; + + if ($name =~ /^\w+$/) { + # Tools with normal name, just export it as an environment variable + $return .= 'export ' . $name . ' = ' . $tool->{$name} . "\n"; + + } else { + # Tools with unusual characters, export using a label/value pair + $return .= 'export FCM_UNUSUAL_TOOL_LABEL' . $count . ' = ' . $name . "\n"; + $return .= 'export FCM_UNUSUAL_TOOL_VALUE' . $count . ' = ' . + $tool->{$name} . "\n"; + $count++; + } + } + + $return .= "\n"; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_vpath (); +# +# DESCRIPTION +# This method returns a makefile $string for defining vpath directives. +# ------------------------------------------------------------------------------ + +sub _write_makefile_vpath { + my $self = shift(); + my $FMT = 'vpath %%%s $(FCM_%sPATH)'; + my %SETTING_OF = %{$self->setting('BLD_VPATH')}; + my %EXT_OF = %{$self->setting('OUTFILE_EXT')}; + # Note: each setting can be either an empty string or a comma-separated list + # of output file extension keys. + join( + "\n", + ( + map + { + my $key = $_; + my @types = split(qr{$DELIMITER_LIST}msx, $SETTING_OF{$key}); + @types ? (map {sprintf($FMT, $EXT_OF{$_}, $key)} sort @types) + : sprintf($FMT, q{}, $key) + ; + } + sort keys(%SETTING_OF) + ), + ) . "\n\n"; +} + +# Wraps chdir. Returns the old working directory. +sub _chdir { + my ($self, $path) = @_; + if ($self->verbose() >= 3) { + printf("cd %s\n", $path); + } + my $old_cwd = cwd(); + chdir($path) || croak(sprintf("%s: cannot change directory ($!)\n", $path)); + $old_cwd; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/94/944ffd1f19a4b2831f7d3066152c72ba7f408ac1.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/94/944ffd1f19a4b2831f7d3066152c72ba7f408ac1.svn-base new file mode 100644 index 0000000..3320309 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/94/944ffd1f19a4b2831f7d3066152c72ba7f408ac1.svn-base @@ -0,0 +1,95 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Exception; +use overload (q{""} => \&as_string); + +use Scalar::Util qw{blessed}; + +# ------------------------------------------------------------------------------ +# Returns true if $e is a blessed instance of this class. +sub caught { + my ($class, $e) = @_; + return (blessed($e) && $e->isa($class)); +} + +# ------------------------------------------------------------------------------ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless( + {message => q{unknown problem}, ($args_ref ? %{$args_ref} : ())}, + $class, + ); +} + +# ------------------------------------------------------------------------------ +# Returns a string representation of this exception +sub as_string { + my ($self) = @_; + return sprintf("%s: %s\n", blessed($self), $self->get_message()); +} + +# ------------------------------------------------------------------------------ +# Returns the message of this exception +sub get_message { + my ($self) = @_; + return $self->{message}; +} + +1; +__END__ + +=head1 NAME + +Fcm::Exception + +=head1 SYNOPSIS + + use Fcm::Exception; + eval { + croak(Fcm::Exception->new({message => $message})); + }; + if ($@) { + if (Fcm::Exception->caught($@)) { + print({STDERR} $@); + } + } + +=head1 DESCRIPTION + +This exception is raised when there is a generic problem in FCM. + +=head1 METHODS + +=over 4 + +=item $class->caught($e) + +Returns true if $e is a blessed instance of this class. + +=item $class->new({message=E$message}) + +Returns a new instance of this exception. Its first argument must be a +reference to a hash containing the detailed I of the exception. + +=item $e->as_string() + +Returns a string representation of this exception. + +=item $e->get_message() + +Returns the detailed message of this exception. + +=back + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/95/95ac1157968bbd5b8425a6c5418eb52f89eeabcb.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/95/95ac1157968bbd5b8425a6c5418eb52f89eeabcb.svn-base new file mode 100644 index 0000000..069396a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/95/95ac1157968bbd5b8425a6c5418eb52f89eeabcb.svn-base @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Interactive::InputGetter::CLI'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests usage of constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my $input_getter = $class->new({}); + isa_ok($input_getter, $class); +} + +# TODO: tests the invoke method + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/98/98fb1eb53b4bac138d7de2340e394cbb8a6ce930.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/98/98fb1eb53b4bac138d7de2340e394cbb8a6ce930.svn-base new file mode 100644 index 0000000..f02cf01 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/98/98fb1eb53b4bac138d7de2340e394cbb8a6ce930.svn-base @@ -0,0 +1,170 @@ +#!/usr/bin/perl +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +use Fcm::CfgLine; +use Fcm::Config; +use Scalar::Util qw{reftype}; +use Test::More (tests => 90); + +BEGIN: { + use_ok('Fcm::ConfigSystem'); +} + +my $CONFIG = undef; + +# ------------------------------------------------------------------------------ +if (!caller()) { + main(@ARGV); +} + +# ------------------------------------------------------------------------------ +sub main { + local @ARGV = @_; + test_compare_setting_in_config(); +} + +# ------------------------------------------------------------------------------ +# Tests "compare_setting_in_config". +sub test_compare_setting_in_config { + my $PREFIX = 'TEST'; + my %S = (egg => [qw{boiled poached}], ham => 'roasted', bacon => 'fried'); + my %S_MOD = (ham => 'boiled'); + my %S_MOD_ARRAY = (egg => [qw{scrambled omelette}]); + my %S_ADD = (mushroom => 'sauteed'); + my %S_DEL = (bacon => undef); + + my @ITEMS = ( + { + name => 'empty', + original => {}, + added => {}, + removed => {}, + modified => {}, + }, + { + name => 'add keys to empty', + original => {}, + added => {%S}, + removed => {}, + modified => {%S}, + }, + { + name => 'remove all', + original => {%S}, + added => {}, + removed => {}, + modified => {map {($_, undef)} keys(%S)}, + }, + { + name => 'no change', + original => {%S}, + added => {%S}, + removed => {}, + modified => {}, + }, + { + name => 'modify key', + original => {%S}, + added => {%S, %S_MOD}, + removed => {}, + modified => {%S_MOD}, + }, + { + name => 'modify an array key', + original => {%S}, + added => {%S, %S_MOD_ARRAY}, + removed => {}, + modified => {%S_MOD_ARRAY}, + }, + { + name => 'add a key', + original => {%S}, + added => {%S, %S_ADD}, + removed => {}, + modified => {%S_ADD}, + }, + { + name => 'delete a key', + original => {%S}, + added => {%S}, + removed => {%S_DEL}, + modified => {%S_DEL}, + }, + { + name => 'modify a key and delete a key', + original => {%S}, + added => {%S, %S_MOD}, + removed => {%S_DEL}, + modified => {%S_MOD, %S_DEL}, + }, + { + name => 'add a key and delete a key', + original => {%S}, + added => {%S, %S_ADD}, + removed => {%S_DEL}, + modified => {%S_ADD, %S_DEL}, + }, + ); + + # A naive function to serialise an array reference + my $flatten = sub { + if (ref($_[0]) && reftype($_[0]) eq 'ARRAY') { + join(q{ }, sort(@{$_[0]})) + } + else { + $_[0]; + } + }; + + my $CONFIG = Fcm::Config->instance(); + for my $item (@ITEMS) { + # New settings + $CONFIG->{setting}{$PREFIX} = {%{$item->{added}}}; + for my $key (keys(%{$item->{removed}})) { + delete($CONFIG->{setting}{$PREFIX}{$key}); + } + + # Old lines + my @old_lines = map { + Fcm::CfgLine->new( + LABEL => $PREFIX . $Fcm::Config::DELIMITER . $_, + VALUE => $flatten->($item->{original}{$_}), + ) + } keys(%{$item->{original}}); + + # Invokes the method + my $system = Fcm::ConfigSystem->new(); + my ($changed_hash_ref, $new_cfg_lines_ref) + = $system->compare_setting_in_config($PREFIX, \@old_lines); + + # Tests the return values + my $T = $item->{name}; + is_deeply( + $changed_hash_ref, $item->{modified}, + "$T: \$changed_hash_ref content", + ); + is( + scalar(@{$new_cfg_lines_ref}), + scalar(keys(%{$item->{added}})) - scalar(keys(%{$item->{removed}})), + "$T: \$new_cfg_lines_ref length", + ); + for my $line (@{$new_cfg_lines_ref}) { + my $key = $line->label_from_field(1); + ok(exists($item->{added}{$key}), "$T: expected label $key"); + ok(!exists($item->{removed}{$key}), "$T: unexpected label $key"); + is( + $line->value(), $flatten->($item->{added}{$key}), + "$T: line content $key", + ); + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/9f/9fde4d0cd50dee672327d71ebe11687c90b12cbf.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/9f/9fde4d0cd50dee672327d71ebe11687c90b12cbf.svn-base new file mode 100644 index 0000000..d32d2ff --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/9f/9fde4d0cd50dee672327d71ebe11687c90b12cbf.svn-base @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + use_ok('Fcm::Util'); + test_tidy_url(); +} + +################################################################################ +# Tests tidy_url +sub test_tidy_url { + my $prefix = "tidy_url"; + my %RESULT_OF = ( + '' => '', + 'foo' => 'foo', + 'foo/bar' => 'foo/bar', + 'http://foo/bar' => 'http://foo/bar', + 'http://foo/bar@1234' => 'http://foo/bar@1234', + 'http://foo/bar/@1234' => 'http://foo/bar@1234', + 'http://foo/bar/.' => 'http://foo/bar', + 'http://foo/bar/.@1234' => 'http://foo/bar@1234', + 'http://foo/bar/./@1234' => 'http://foo/bar@1234', + 'http://foo/bar/./baz' => 'http://foo/bar/baz', + 'http://foo/bar/..' => 'http://foo', + 'http://foo/bar/..@1234' => 'http://foo@1234', + 'http://foo/bar/../@1234' => 'http://foo@1234', + 'http://foo/bar/../baz' => 'http://foo/baz', + 'http://foo/bar/../.' => 'http://foo', + 'http://foo/bar/baz/../..' => 'http://foo', + ); + for my $key (sort keys(%RESULT_OF)) { + is(tidy_url($key), $RESULT_OF{$key}, "$prefix: $key"); + } +} + +# TODO: more unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a0/a0f23f8800d71739ea52464590e17407b380a2c9.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a0/a0f23f8800d71739ea52464590e17407b380a2c9.svn-base new file mode 100644 index 0000000..5639705 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a0/a0f23f8800d71739ea52464590e17407b380a2c9.svn-base @@ -0,0 +1,69 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::CM; +use base qw{Fcm::CLI::Invoker}; + +use Fcm::Cm qw{cli}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + return cli($self->get_command(), @ARGV); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::CM + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::CM; + $invoker = Fcm::CLI::Invoker::CM->new(); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke a command in the CM +sub-system. + +It is worth noting that this is not yet a full implementation. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes a command in the CM sub-system. + +=back + +=head1 TO DO + +Bring the CM system into this framework. + +Unit tests. + +=head1 SEE ALSO + +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a5/a5e73e4db25e1249f80ef70d5f888505287fdfe3.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a5/a5e73e4db25e1249f80ef70d5f888505287fdfe3.svn-base new file mode 100644 index 0000000..e7ed087 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a5/a5e73e4db25e1249f80ef70d5f888505287fdfe3.svn-base @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Config::Default'; + use_ok($class); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a9/a90bbaf18b42f2ceb5ce79f7ccfe4862db8b2b81.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a9/a90bbaf18b42f2ceb5ce79f7ccfe4862db8b2b81.svn-base new file mode 100644 index 0000000..22c8b14 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/a9/a90bbaf18b42f2ceb5ce79f7ccfe4862db8b2b81.svn-base @@ -0,0 +1,60 @@ +=head1 NAME + +fcm mkpatch + +=head1 SYNOPSIS + +mkpatch: Create patches from specified revisions of a URL + + fcm mkpatch [OPTIONS] URL [OUTDIR] + +Create patches from specified revisions of the specified URL. If OUTDIR is +specified, the output is sent to OUTDIR. Otherwise, the output will be sent to a +default location in the current directory ($PWD/fcm-mkpatch-out). The output +directory will contain the patch for each revision as well as a script for +importing the patch. + +A warning is given if the URL is not of a branch in a FCM project or if it is a +sub-directory of a branch. + +=head1 OPTIONS + +=over 4 + +=item --exclude arg + +Exclude a path in the URL. Multiple paths can be specified by using a +colon-separated list of paths, or by specifying this option multiple times. + +The specified path must be a relative path of the URL. Glob patterns such as * +and ? are acceptable. Changes in an excluded path will not be considered in the +patch. A changeset containing changes only in the excluded path will not be +considered at all. + +=item --organisation arg + +This option can be used to specify the name of your organisation. + +The command will attempt to parse the commit log message for each revision in +the patch. It will remove all merge templates, replace Trac links with a +modified string, and add information about the original changeset. If you +specify the name of your organisation, it will replace Trac links such as +"ticket:123" with "$organisation_ticket:123", and report the original changeset +with a message such as "$organisation_changeset:1000". If the organisation +name is not specified then it defaults to "original". + +=item -r [--revision] arg + +Specify a revision number or a revision number range. + +If a revision is specified with the --revision option, it will attempt to create +a patch based on the changes at that revision. If a revision is not specified, +it will attempt to create a patch based on the changes at the HEAD revision. If +a revision range is specified, it will attempt to create a patch for each +revision in that range (including the change in the lower range) where changes +have taken place in the URL. No output will be written if there is no change in +the given revision (range). + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/aa/aafbcd8eaecbad64769ed88e6166348f7552ff9c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/aa/aafbcd8eaecbad64769ed88e6166348f7552ff9c.svn-base new file mode 100644 index 0000000..7221812 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/aa/aafbcd8eaecbad64769ed88e6166348f7552ff9c.svn-base @@ -0,0 +1,410 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ExtractFile +# +# DESCRIPTION +# Select/combine a file in different branches and extract it to destination. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use warnings; +use strict; + +package Fcm::ExtractFile; +use base qw{Fcm::Base}; + +use Fcm::Util qw{run_command w_report}; +use File::Basename qw{dirname}; +use File::Compare qw{compare}; +use File::Copy qw{copy}; +use File::Path qw{mkpath}; +use File::Spec; +use File::Temp qw(tempfile); + +# List of property methods for this class +my @scalar_properties = ( + 'conflict', # conflict mode + 'dest', # search path to destination file + 'dest_status', # destination status, see below + 'pkgname', # package name of this file + 'src', # list of Fcm::ExtractSrc, specified for this file + 'src_actual', # list of Fcm::ExtractSrc, actually used by this file + 'src_status', # source status, see below +); + +# Status code definition for $self->dest_status +our %DEST_STATUS_CODE = ( + '' => 'unchanged', + 'M' => 'modified', + 'A' => 'added', + 'a' => 'added, overridding inherited', + 'D' => 'deleted', + 'd' => 'deleted, overridding inherited', + '?' => 'irrelevant', +); + +# Status code definition for $self->src_status +our %SRC_STATUS_CODE = ( + 'A' => 'added by a branch', + 'B' => 'from the base', + 'D' => 'deleted by a branch', + 'M' => 'modified by a branch', + 'G' => 'merged from 2+ branches', + 'O' => 'overridden by a branch', + '?' => 'irrelevant', +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ExtractFile->new (); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ExtractFile class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{$_} ? $args{$_} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'conflict') { + $self->{$name} = 'merge'; # default to "merge" mode + + } elsif ($name eq 'dest' or $name eq 'src' or $name eq 'src_actual') { + $self->{$name} = []; # default to an empty list + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->run(); +# +# DESCRIPTION +# This method runs only if $self->dest_status is not defined. It updates the +# destination according to the source in the list and the conflict mode +# setting. It updates the file in $self->dest as appropriate and sets +# $self->dest_status. (See above.) This method returns true on success. +# ------------------------------------------------------------------------------ + +sub run { + my ($self) = @_; + my $rc = 1; + + if (not defined ($self->dest_status)) { + # Assume file unchanged + $self->dest_status (''); + + if (@{ $self->src }) { + my $used; + # Determine or set up a file for comparing with the destination + ($rc, $used) = $self->run_get_used(); + + # Attempt to compare the destination with $used. Update on change. + if ($rc) { + $rc = defined ($used) ? $self->run_update($used) : $self->run_delete(); + } + + } else { + # No source, delete file in destination + $self->src_status ('?'); + $rc = $self->run_delete(); + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->run_delete(); +# +# DESCRIPTION +# This method is part of run(). It detects this file in the destination path. +# If this file is in the current destination, it attempts to delete it and +# sets the dest_status to "D". If this file is in an inherited destination, +# it sets the dest_status to "d". +# ------------------------------------------------------------------------------ + +sub run_delete { + my ($self) = @_; + + my $rc = 1; + + $self->dest_status ('?'); + for my $i (0 .. @{ $self->dest } - 1) { + my $dest = File::Spec->catfile ($self->dest->[$i], $self->pkgname); + next unless -f $dest; + if ($i == 0) { + $rc = unlink $dest; + $self->dest_status ('D'); + + } else { + $self->dest_status ('d'); + last; + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $used) = $obj->run_get_used(); +# +# DESCRIPTION +# This method is part of run(). It attempts to work out or set up the $used +# file. ($used is undef if it is not defined in a branch for this file.) +# ------------------------------------------------------------------------------ + +sub run_get_used { + my ($self) = @_; + my $rc = 1; + my $used; + + my @sources = ($self->src->[0]); + my $src_status = 'B'; + if (defined ($self->src->[0]->cache)) { + # File exists in base branch + for my $i (1 .. @{ $self->src } - 1) { + if (defined ($self->src->[$i]->cache)) { + # Detect changes in this file between base branch and branch $i + push @sources, $self->src->[$i] + if &compare ($self->src->[0]->cache, $self->src->[$i]->cache); + + } else { + # File deleted in branch $i + @sources = ($self->src->[$i]); + last unless $self->conflict eq 'override'; + } + } + + if ($rc) { + if (@sources > 2) { + if ($self->conflict eq 'fail') { + # On conflict, fail in fail mode + w_report 'ERROR: ', $self->pkgname, + ': modified in 2+ branches in fail conflict mode.'; + $rc = undef; + + } elsif ($self->conflict eq 'override') { + $used = $sources[-1]->cache; + $src_status = 'O'; + + } else { + # On conflict, attempt to merge in merge mode + ($rc, $used) = $self->run_get_used_by_merge (@sources); + $src_status = 'G' if $rc; + } + + } else { + # 0 or 1 change, use last source + if (defined $sources[-1]->cache) { + $used = $sources[-1]->cache; + $src_status = 'M' if @sources > 1; + + } else { + $src_status = 'D'; + } + } + } + + } else { + # File does not exist in base branch + @sources = ($self->src->[-1]); + $used = $self->src->[1]->cache; + $src_status = (defined ($used) ? 'A' : 'D'); + if ($self->conflict ne 'override' and defined ($used)) { + for my $i (1 - @{ $self->src } .. -2) { + # Allow this only if files are the same in all branches + my $file = $self->src->[$i]->cache; + if ((not defined ($file)) or &compare ($used, $file)) { + w_report 'ERROR: ', $self->pkgname, ': cannot merge:', + ' not found in base branch,', + ' but differs in subsequent branches.'; + $rc = undef; + last; + + } else { + unshift @sources, $self->src->[$i]; + } + } + } + } + + $self->src_status ($src_status); + $self->src_actual (\@sources); + + return ($rc, $used); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $used) = $obj->run_get_used_by_merge(@soruces); +# +# DESCRIPTION +# This method is part of run_get_used(). It attempts to merge the files in +# @sources and return a temporary file $used. @sources should be an array of +# Fcm::ExtractSrc objects. On success, $rc will be set to true. +# ------------------------------------------------------------------------------ + +sub run_get_used_by_merge { + my ($self, @sources) = @_; + my $rc = 1; + + # Get temporary file + my ($fh, $used) = &tempfile ('fcm.ext.merge.XXXXXX', UNLINK => 1); + close $fh or die $used, ': cannot close'; + + for my $i (2 .. @sources - 1) { + # Invoke the diff3 command to merge + my $mine = ($i == 2 ? $sources[1]->cache : $used); + my $older = $sources[0]->cache; + my $yours = $sources[$i]->cache; + my @command = ( + $self->setting (qw/TOOL DIFF3/), + split (/\s+/, $self->setting (qw/TOOL DIFF3FLAGS/)), + $mine, $older, $yours, + ); + my $code; + my @out = &run_command ( + \@command, + METHOD => 'qx', + ERROR => 'ignore', + PRINT => $self->verbose > 1, + RC => \$code, + TIME => $self->verbose > 2, + ); + + if ($code) { + # Failure, report and return + my $m = ($code == 1) + ? 'cannot resolve conflicts:' + : $self->setting (qw/TOOL DIFF3/) . 'command failed'; + w_report 'ERROR: ', $self->pkgname, ': merge - ', $m; + if ($code == 1 and $self->verbose) { + for (0 .. $i) { + my $src = $sources[$_]->uri eq $sources[$_]->cache + ? $sources[$_]->cache + : ($sources[$_]->uri . '@' . $sources[$_]->rev); + w_report ' source[', $_, ']=', $src; + } + + for (0 .. $i) { + w_report ' cache', $_, '=', $sources[$_]->cache; + } + + w_report @out if $self->verbose > 2; + } + $rc = undef; + last; + + } else { + # Success, write result to temporary file + open FILE, '>', $used or die $used, ': cannot open (', $!, ')'; + print FILE @out; + close FILE or die $used, ': cannot close (', $!, ')'; + + # File permission, use most permissive combination of $mine and $yours + my $perm = ((stat($mine))[2] & 07777) | ((stat($yours))[2] & 07777); + chmod ($perm, $used); + } + } + + return ($rc, $used); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->run_update($used_file); +# +# DESCRIPTION +# This method is part of run(). It compares the $used_file with the one in +# the destination. If the file does not exist in the destination or if its +# content is out of date, the destination is updated with the content in the +# $used_file. Returns true on success. +# ------------------------------------------------------------------------------ + +sub run_update { + my ($self, $used_file) = @_; + my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1); + + # Compare with the previous version if it exists + DEST: + for my $i (0 .. @{$self->dest()} - 1) { + my $prev_file = File::Spec->catfile($self->dest()->[$i], $self->pkgname()); + if (-f $prev_file) { + $is_in_prev = $i; + $is_diff = compare($used_file, $prev_file); + $is_diff_in_perms = (stat($used_file))[2] != (stat($prev_file))[2]; + last DEST; + } + } + if (!$is_diff && !$is_diff_in_perms) { + return $rc; + } + + # Update destination + my $dest_file = File::Spec->catfile($self->dest()->[0], $self->pkgname()); + if ($is_diff) { + my $dir = dirname($dest_file); + if (!-d $dir) { + mkpath($dir); + } + $rc = copy($used_file, $dest_file); + } + $rc &&= chmod((stat($used_file))[2] & oct(7777), $dest_file); + if ($rc) { + $self->dest_status( + $is_in_prev ? 'a' + : defined($is_in_prev) ? 'M' + : 'A' + ); + } + return $rc; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ac/ac85e2df063d21aeaf75878fbc50aff644640715.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ac/ac85e2df063d21aeaf75878fbc50aff644640715.svn-base new file mode 100644 index 0000000..eebf529 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ac/ac85e2df063d21aeaf75878fbc50aff644640715.svn-base @@ -0,0 +1,83 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::ExtractConfigComparator; +use base qw{Fcm::CLI::Invoker}; + +use Cwd qw{cwd}; +use Fcm::ExtractConfigComparator; +use Fcm::Config; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my ($cfg_file1, $cfg_file2) = $self->get_arguments(); + if (exists($self->get_options()->{verbose})) { + Fcm::Config->instance()->verbose($self->get_options()->{verbose}); + } + + my $system = Fcm::ExtractConfigComparator->new({ + files => [$cfg_file1, $cfg_file2], wiki => $self->get_options()->{wiki}, + }); + $system->invoke(); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::ExtractInvoker + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::ExtractConfigComparator; + $invoker = Fcm::CLI::Invoker::ExtractConfigComparator->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke the extract configuration +comparator. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the extract configuration comparator. + +The I option is mapped directly to that of the constructor of +L object. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/ae27bb0075a0e9e4320ce20ec402a7c0f4f88799.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/ae27bb0075a0e9e4320ce20ec402a7c0f4f88799.svn-base new file mode 100644 index 0000000..d4a3453 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/ae27bb0075a0e9e4320ce20ec402a7c0f4f88799.svn-base @@ -0,0 +1,17 @@ +=head1 NAME + +fcm conflicts (cf) + +=head1 SYNOPSIS + +Use graphical tool to resolve any conflicts within your working copy. + + fcm conflicts [PATH] + +=head1 ARGUMENTS + +Invoke a graphical merge tool to help you resolve conflicts in your working copy +at PATH. It prompts you to run "L resolved" each time you have resolved +the conflicts in a text file. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/ae86efc3a288bada5dae067fdb1012008ef87196.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/ae86efc3a288bada5dae067fdb1012008ef87196.svn-base new file mode 100644 index 0000000..334e39f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/ae86efc3a288bada5dae067fdb1012008ef87196.svn-base @@ -0,0 +1,117 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::ConfigSystem; +use base qw{Fcm::CLI::Invoker}; + +use Cwd qw{cwd}; +use Fcm::CLI::Exception; +use Fcm::Config; +use Fcm::Util::ClassLoader; + +################################################################################ +# Returns a hash map to convert CLI options to system invoke options. +sub get_cli2invoke_key_map { + my ($self) = @_; + return ( + wantarray() ? %{$self->{cli2invoke_key_map}} + : $self->{cli2invoke_key_map} + ); +} + +################################################################################ +# Returns the Fcm::ConfigSystem class for invoking the sub-system. +sub get_impl_class { + my ($self) = @_; + return $self->{impl_class}; +} + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my $options_ref = $self->get_options(); + if (exists($options_ref->{verbose})) { + Fcm::Config->instance()->verbose($options_ref->{verbose}); + } + + Fcm::Util::ClassLoader::load($self->get_impl_class()); + my $system = $self->get_impl_class()->new(); + my ($cfg_file) = $self->get_arguments(); + $system->cfg()->src($cfg_file ? $cfg_file : cwd()); + + my %map = $self->get_cli2invoke_key_map(); + my %invoke_args = map {($map{$_}, $options_ref->{$_})} keys(%map); + $system->invoke(%invoke_args); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoke::ConfigSystem + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::ConfigSystem; + $invoker = Fcm::CLI::Invoker::ConfigSystem->new({ + command => $command, + options => \%options, + arguments => $arguments, + impl_class => $class_name, + cli2invoke_key_map => { + option => 'OPTION', + # ... more keys + }, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L and inherits all its +methods. An object of this class is used to invoke a +L, e.g. extract and build. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item get_cli2invoke_key_map() + +Returns a hash containing a mapping table from the names of the relevant command +line options to the names to be given to the invoke() method of the implementing +L object. + +=item get_impl_class() + +Returns the actual class that implements L. +An object of this implementation will be created and used by invoke(). + +=item invoke() + +Invokes the L sub-system. If a +configuration file is not specified in the argument, it uses the current working +directory. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/aebb514918c357ed1824233959aa47f3ba144343.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/aebb514918c357ed1824233959aa47f3ba144343.svn-base new file mode 100644 index 0000000..9dc3daf --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ae/aebb514918c357ed1824233959aa47f3ba144343.svn-base @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Interactive::InputGetter'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests usage of constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my $input_getter = $class->new({ + title => 'title-value', + message => 'message-value', + type => 'type-value', + default => 'default-value', + }); + isa_ok($input_getter, $class); + is($input_getter->get_title(), 'title-value', "$prefix: get title"); + is($input_getter->get_message(), 'message-value', "$prefix: get message"); + is($input_getter->get_type(), 'type-value', "$prefix: get type"); + is($input_getter->get_default(), 'default-value', "$prefix: get default"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b3/b31f649771db1c91c424a6bb25b5ae5935f5ebd7.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b3/b31f649771db1c91c424a6bb25b5ae5935f5ebd7.svn-base new file mode 100644 index 0000000..c74ea59 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b3/b31f649771db1c91c424a6bb25b5ae5935f5ebd7.svn-base @@ -0,0 +1,358 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +################################################################################ +# A generic reporter of the comparator's result +{ + package Reporter; + + ############################################################################ + # Class method: Constructor + sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); + } + + ############################################################################ + # Class method: Factory for Reporter object + sub get_reporter { + my ($self, $comparator) = @_; + my $class = defined($comparator->get_wiki()) ? 'WikiReporter' + : 'TextReporter' + ; + return $class->new(); + } + + ############################################################################ + # Reports the results + sub report { + my ($self, $comparator) = @_; + if (keys(%{$comparator->get_log_of()})) { + print("Revisions at which extract declarations are modified:\n\n"); + } + $self->report_impl($comparator); + } + + ############################################################################ + # Does the actual reporting + sub report_impl { + my ($self, $comparator) = @_; + } +} + +################################################################################ +# Reports the comparator's result in Trac wiki format +{ + package WikiReporter; + our @ISA = qw{Reporter}; + + use Fcm::CmUrl; + use Fcm::Keyword; + use Fcm::Util qw{tidy_url}; + + ############################################################################ + # Reports the comparator's result + sub report_impl { + my ($self, $comparator) = @_; + # Output in wiki format + my $wiki_url = Fcm::CmUrl->new( + URL => tidy_url(Fcm::Keyword::expand($comparator->get_wiki())) + ); + my $base_trac + = $comparator->get_wiki() + ? Fcm::Keyword::get_browser_url($wiki_url->project_url()) + : $wiki_url; + if (!$base_trac) { + $base_trac = $wiki_url; + } + + for my $key (sort keys(%{$comparator->get_log_of()})) { + my $branch_trac = Fcm::Keyword::get_browser_url($key); + $branch_trac =~ s{\A $base_trac (?:/*|\z)}{source:}xms; + print("[$branch_trac]:\n"); + my %branch_of = %{$comparator->get_log_of()->{$key}}; + for my $rev (sort {$b <=> $a} keys(%branch_of)) { + print( + $branch_of{$rev}->display_svnlog($rev, $base_trac), "\n", + ); + } + print("\n"); + } + } +} + +################################################################################ +# Reports the comparator's result in simple text format +{ + package TextReporter; + our @ISA = qw{Reporter}; + + use Fcm::Config; + + my $SEPARATOR = q{-} x 80 . "\n"; + + ############################################################################ + # Reports the comparator's result + sub report_impl { + my ($self, $comparator) = @_; + for my $key (sort keys(%{$comparator->get_log_of()})) { + # Output in plain text format + print $key, ':', "\n"; + my %branch_of = %{$comparator->get_log_of()->{$key}}; + if (Fcm::Config->instance()->verbose() > 1) { + for my $rev (sort {$b <=> $a} keys(%branch_of)) { + print( + $SEPARATOR, $branch_of{$rev}->display_svnlog($rev), "\n" + ); + } + } + else { + print(join(q{ }, sort {$b <=> $a} keys(%branch_of)), "\n"); + } + print $SEPARATOR, "\n"; + } + } +} + +package Fcm::ExtractConfigComparator; + +use Fcm::CmUrl; +use Fcm::Extract; + +################################################################################ +# Class method: Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns an array containing the 2 configuration files to compare +sub get_files { + my ($self) = @_; + return (wantarray() ? @{$self->{files}} : $self->{files}); +} + +################################################################################ +# Returns the wiki link on wiki mode +sub get_wiki { + my ($self) = @_; + return $self->{wiki}; +} + +################################################################################ +# Returns the result log +sub get_log_of { + my ($self) = @_; + return (wantarray() ? %{$self->{log_of}} : $self->{log_of}); +} + +################################################################################ +# Invokes the comparator +sub invoke { + my ($self) = @_; + + # Reads the extract configurations + my (@cfg, $rc); + for my $i (0 .. 1) { + $cfg[$i] = Fcm::Extract->new(); + $cfg[$i]->cfg()->src($self->get_files()->[$i]); + $cfg[$i]->parse_cfg(); + $rc = $cfg[$i]->expand_cfg(); + if (!$rc) { + e_report(); + } + } + + # Get list of URLs + # -------------------------------------------------------------------------- + my @urls = (); + for my $i (0 .. 1) { + # List of branches in each extract configuration file + my @branches = @{$cfg[$i]->branches()}; + BRANCH: + for my $branch (@branches) { + # Ignore declarations of local directories + if ($branch->type() eq 'user') { + next BRANCH; + } + + # List of SRC declarations in each branch + my %dirs = %{$branch->dirs()}; + + for my $dir (values(%dirs)) { + # Set up a new instance of Fcm::CmUrl object for each SRC + my $cm_url = Fcm::CmUrl->new ( + URL => $dir . ( + $branch->revision() ? '@' . $branch->revision() : q{} + ), + ); + + $urls[$i]{$cm_url->branch_url()}{$dir} = $cm_url; + } + } + } + + # Compare + # -------------------------------------------------------------------------- + $self->{log_of} = {}; + for my $i (0 .. 1) { + # Compare the first file with the second one and then vice versa + my $j = ($i == 0) ? 1 : 0; + + for my $branch (sort keys(%{$urls[$i]})) { + if (exists($urls[$j]{$branch})) { + # Same REPOS declarations in both files + DIR: + for my $dir (sort keys(%{$urls[$i]{$branch}})) { + if (exists($urls[$j]{$branch}{$dir})) { + if ($i == 1) { + next DIR; + } + + my $this_url = $urls[$i]{$branch}{$dir}; + my $that_url = $urls[$j]{$branch}{$dir}; + + # Compare their last changed revisions + my $this_rev + = $this_url->svninfo(FLAG => 'Last Changed Rev'); + my $that_rev + = $that_url->svninfo(FLAG => 'Last Changed Rev'); + + # Make sure last changed revisions differ + if ($this_rev eq $that_rev) { + next DIR; + } + + # Not interested in the log before the minimum revision + my $min_rev + = $this_url->pegrev() > $that_url->pegrev() + ? $that_url->pegrev() : $this_url->pegrev(); + + $this_rev = $min_rev if $this_rev < $min_rev; + $that_rev = $min_rev if $that_rev < $min_rev; + + # Get list of changed revisions using the commit log + my $u = ($this_rev > $that_rev) ? $this_url : $that_url; + my %revs = $u->svnlog(REV => [$this_rev, $that_rev]); + + REV: + for my $rev (keys %revs) { + # Check if revision is already in the list + if ( + exists($self->{log_of}{$branch}{$rev}) + || $rev == $min_rev + ) { + next REV; + } + + # Get list of changed paths. Accept this revision + # only if it contains changes in the current branch + my %paths = %{$revs{$rev}{paths}}; + + PATH: + for my $path (keys(%paths)) { + my $change_url + = Fcm::CmUrl->new(URL => $u->root() . $path); + + if ($change_url->branch() eq $u->branch()) { + $self->{log_of}{$branch}{$rev} = $u; + last PATH; + } + } + } + } + else { + $self->_report_added( + $urls[$i]{$branch}{$dir}->url_peg(), $i, $j); + } + } + } + else { + $self->_report_added($branch, $i, $j); + } + } + } + + my $reporter = Reporter->get_reporter($self); + $reporter->report($self); + return $rc; +} + +################################################################################ +# Reports added/deleted declaration +sub _report_added { + my ($self, $branch, $i, $j) = @_; + printf( + "%s:\n in : %s\n not in: %s\n\n", + $branch, $self->get_files()->[$i], $self->get_files()->[$j], + ); +} + +1; +__END__ + +=head1 NAME + +Fcm::ExtractConfigComparator + +=head1 SYNOPSIS + + use Fcm::ExtractConfigComparator; + my $comparator = Fcm::ExtractConfigComparator->new({files => \@files}); + $comparator->invoke(); + +=head1 DESCRIPTION + +An object of this class represents a comparator of FCM extract configuration. +It is used to compare the VC branch declarations in 2 FCM extract configuration +files. + +=head1 METHODS + +=over 4 + +=item C \@files, wiki =E $wiki})> + +Constructor. + +=item get_files() + +Returns an array containing the 2 configuration files to compare. + +=item get_wiki() + +Returns the wiki link on wiki mode. + +=item invoke() + +Invokes the comparator. + +=back + +=head1 TO DO + +More documentation. + +Improve the parser for extract configuration. + +Separate the comparator with the reporters. + +Add reporter to display HTML. + +More unit tests. + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b4/b42092e63ee4bcf796c09a7ea92d66c23c34a87f.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b4/b42092e63ee4bcf796c09a7ea92d66c23c34a87f.svn-base new file mode 100644 index 0000000..395206e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b4/b42092e63ee4bcf796c09a7ea92d66c23c34a87f.svn-base @@ -0,0 +1,131 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive; +use base qw{Exporter}; + +our @EXPORT_OK = qw{get_input}; + +use Fcm::Util::ClassLoader; + +my $DEFAULT_IMPL_CLASS = 'Fcm::Interactive::InputGetter::CLI'; +my %DEFAULT_IMPL_CLASS_OPTIONS = (); + +my $IMPL_CLASS = $DEFAULT_IMPL_CLASS; +my %IMPL_CLASS_OPTIONS = %DEFAULT_IMPL_CLASS_OPTIONS; + +################################################################################ +# Returns the name of the current class/settings for getting input +sub get_impl { + return (wantarray() ? ($IMPL_CLASS, \%IMPL_CLASS_OPTIONS) : $IMPL_CLASS); +} + +################################################################################ +# Returns the name of the current class/settings for getting input +sub get_default_impl { + return ( + wantarray() + ? ($DEFAULT_IMPL_CLASS, \%DEFAULT_IMPL_CLASS_OPTIONS) + : $DEFAULT_IMPL_CLASS + ); +} + +################################################################################ +# Sets the name of the class/settings for getting input +sub set_impl { + my ($impl_class, $impl_class_options_ref) = @_; + if ($impl_class) { + $IMPL_CLASS = $impl_class; + if ($impl_class_options_ref) { + %IMPL_CLASS_OPTIONS = (%{$impl_class_options_ref}); + } + else { + %IMPL_CLASS_OPTIONS = (); + } + } +} + +################################################################################ +# Gets an input from the user and returns it +sub get_input { + my (%options) = @_; + my ($class_name, $class_options_ref) = get_impl(); + Fcm::Util::ClassLoader::load($class_name); + %options = map {lc($_), $options{$_}} keys(%options); + return $class_name->new({%{$class_options_ref}, %options})->invoke(); +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive + +=head1 SYNOPSIS + + use Fcm::Interactive; + Fcm::Interactive::set_impl('My::InputGetter', {option1 => 'value1', ...}); + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +Common interface for getting an interactive user reply. The default is to use a +L object +with no extra options. + +=head1 FUNCTIONS + +=over 4 + +=item get_impl() + +Returns the class that implements the function for get_input(%options). In +scalar context, returns the class name only. In list context, returns the class +name and the extra hash options that would be passed to its constructor. + +=item get_default_impl() + +Returns the defaut values for get_impl(). + +=item set_impl($impl_class,$impl_class_options_ref) + +Sets the class that implements the function for get_input(%options). The name +of the class is given in $impl_class. Any extra options that should be given to +the constructor should be set in the hash reference $impl_class_options_ref. + +=item get_input(%options) + +Calls the appropriate function to get an input string from the user, and +returns it. + +Input options are: I, for a short title of the prompt, I<message>, for +the message prompt, I<type> for the prompt type, and I<default> for the default +value of the return value. + +Prompt type can be YN (yes or no), YNA (yes, no or all) or input (for an input +string). + +=back + +=head1 SEE ALSO + +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, +L<Fcm::Interactive::InputGetter::CLI|Fcm::Interactive::InputGetter::CLI>, +L<Fcm::Interactive::InputGetter::GUI|Fcm::Interactive::InputGetter::GUI> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b7/b7ed5df158b7a61b558b1b759a18d838ac6d48b3.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b7/b7ed5df158b7a61b558b1b759a18d838ac6d48b3.svn-base new file mode 100644 index 0000000..2a74773 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b7/b7ed5df158b7a61b558b1b759a18d838ac6d48b3.svn-base @@ -0,0 +1,109 @@ +!------------------------------------------------------------------------------! +! Flexible Configuration Management Software License ! +! ! +! Please read this Software Licence as you will be bound by its terms ! +! if you use the Software ! +!------------------------------------------------------------------------------! + +The Licensor: +------------- + +The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom +-------------------------------------------------------------------------------- + +1. Licence. +----------- + +The Met Office grants you a non-exclusive, royalty free; world-wide, +transferable Licence to use, modify, copy and distribute the Flexible +Configuration Management software ("the software") accompanying this License +providing: + +a. you undertake to provide to the Met Office a copy of any modifications made + by you on the same terms contained within this licence agreement; + +b. modified files carry prominent notices stating that you changed the files + and the date of change; + +c. distribution of original or modified files is made free of charge under the + terms of this Licence; + +d. the appropriate copyright notices, the above copyright notice and a + disclaimer of warranty is included with the distribution. + +2. Ownership. +------------- + +The Flexible Configuration Management software is Crown copyright and is +reproduced with the permission of Met Office under delegated authority from +the Controller of HMSO. The software and documentation are provided to you to +allow you to exercise your rights under this License, which is granted to you. + +3. Duration. +------------ + +This license will remain in effect until terminated. + +4. Termination. +--------------- + +You may terminate this license at any time by removing all copies of the +software from your system. This License will terminate immediately without +notice from us if you fail to comply with any of the provisions of this +License or in the event of your breaching the terms of this licence you are +given notice that the license has been terminated. Upon termination you will +delete all copies of the software and any related documentation. + +5. Disclaimer of Warranty. +-------------------------- + +a. THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES, + INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY + AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY + REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND + PLATFORMS. + +b. In no event does the Met Office warrant that the software or related + documentation will satisfy your requirements, that the software and + documentation will be without errors or defects or that the operation of + the software will be uninterrupted. + +c. IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES, INCLUDING + BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE SOFTWARE + OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF THE MET + OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +6. General Provisions. +---------------------- + +a. You will not do anything, relating to this software that will bring the Met + Office into disrepute. + +b. You will not use the name of the Met Office or any other contributor to + endorse or promote any products derived from the software without the + written permission of the Met Office. + +7. Acknowledgements. +-------------------- + +The logic to extract the calling interfaces of top level subroutines and +functions from a Fortran source file is adapted from a script developed at +ECMWF and is provided by kind permission of ECMWF under the same terms of this +Licence. + +8. Entire Agreement. +-------------------- + +This License constitutes the entire agreement between us with respect to your +rights or warranties for using the software and related documentation. If any +provision of this agreement is determined to be invalid or unenforceable the +remaining provisions shall continue in full force. + +9. Governing Law. +----------------- + +This Agreement is governed by and construed in accordance with the Laws of +England. + +-------------------------------------------------------------------------------- + � British Crown copyright 2006-10. diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b8/b8112361b0b51e8c3b99052f4911a5e210e0faf7.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b8/b8112361b0b51e8c3b99052f4911a5e210e0faf7.svn-base new file mode 100644 index 0000000..e8ba467 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/b8/b8112361b0b51e8c3b99052f4911a5e210e0faf7.svn-base @@ -0,0 +1,70 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::GUI; +use base qw{Fcm::CLI::Invoker}; + +use Fcm::Util qw{run_command}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my ($target) = $self->get_arguments(); + run_command(['fcm_gui', ($target ? $target : ())], METHOD => 'exec'); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::GUIInvoker + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::GUI; + $invoker = Fcm::CLI::Invoker::GUI->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke($command, \%options, $target); + +=head1 DESCRIPTION + +This class extends L<Fcm::CLI::Invoker|Fcm::CLI::Invoker> an inherits all its +methods. An object of this class is used to invoke the FCM GUI. + +=head1 METHODS + +See L<Fcm::CLI::Invoker|Fcm::CLI::Invoker> for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the FCM GUI. If a target is specified as argument, it is the initial +working directory of the GUI. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>, +L<Fcm::CLI::Subcommand|Fcm::CLI::Subcommand> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ba/ba3da52eb85f940985582ee4540ba0efb89e1a24.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ba/ba3da52eb85f940985582ee4540ba0efb89e1a24.svn-base new file mode 100644 index 0000000..4904295 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ba/ba3da52eb85f940985582ee4540ba0efb89e1a24.svn-base @@ -0,0 +1,289 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Cwd qw{cwd}; +use Getopt::Long qw{GetOptions}; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Util qw{get_url_of_wc get_wct is_wc run_command tidy_url}; +use File::Basename qw{basename dirname}; +use File::Path qw{mkpath}; +use File::Spec; +use Pod::Usage qw{pod2usage}; + +# Usage +# ------------------------------------------------------------------------------ +my $this = basename($0); + +# Options +# ------------------------------------------------------------------------------ +my ($dest, $full, $help, $url); +my $rc = GetOptions( + 'dest|d=s' => \$dest, + 'full|f' => \$full, + 'help' => \$help, + 'url|u=s' => \$url, +); +if (!$rc) { + pod2usage({'-verbose' => 1}); +} +if ($help) { + pod2usage({'-exitval' => 0, '-verbose' => 1}); +} +if (!$url) { + pod2usage( + {'-message' => 'The --url=URL option is compulsory', '-verbose' => 1}, + ); +} +$dest ||= cwd(); + +# Arguments +# ------------------------------------------------------------------------------ +if (@ARGV) { + die 'Cannot read: ', $ARGV[0], ', abort' unless -f $ARGV[0] and -r $ARGV[0]; +} + +# Get configuration settings +# ------------------------------------------------------------------------------ +my $config = Fcm::Config->new (); +$config->get_config (); + +# Expand URL keyword +$url = Fcm::Util::tidy_url(Fcm::Keyword::expand($url)); + +# ------------------------------------------------------------------------------ + +MAIN: { + my $date = localtime; + print $this, ': started on ', $date, "\n"; + + my %dirs; + + # Read input (file) for a list directories and update conditions + while (<>) { + chomp; + + # Ignore empty and comment lines + next if /^\s*(?:#|$)/; + + # Each line must contain a relative path, and optionally a list of + # space delimited conditions + my @words = split /\s+/; + my $dir = shift @words; + + # Check that the conditions are valid + my @conditions; + for my $word (@words) { + if ($word =~ /^([<>]=?|[!=]=)(.+)$/i) { + # Condition must be a conditional operator followed by a revision + my ($operator, $rev) = ($1, $2); + $rev = (Fcm::Keyword::expand($url, $rev))[1]; + push @conditions, $operator . $rev; + + } else { + print STDERR 'Warning: ignore unknown syntax for update condition: ', + $word, "\n"; + } + } + + # Add directory and its conditions to a hash + if ($dir =~ s#/\*$##) { # Directory finishes with wildcard + + # Run "svn ls" in recursive mode + my $dirurl = join ('/', ($url, $dir)); + my @files = &run_command ([qw/svn ls -R/, $dirurl], METHOD => 'qx'); + + # Find directories containing regular files + while (my $file = shift @files) { + # Skip directories + next if $file =~ m#/$#; + + # Get "dirname" of regular file and add to hash + my $subdir = join ('/', ($dir, dirname ($file))); + $dirs{$subdir} = \@conditions; + } + + } else { + $dirs{$dir} = \@conditions; + } + + } + + # Update each directory, if required + for my $dir (sort keys %dirs) { + # Use "svn log" to determine the revisions that need to be updated + my %allversions; + { + my $command = 'svn log -q ' . join ('/', ($url, $dir)); + my @log = &run_command ( + [qw/svn log -q/, join ('/', ($url, $dir))], METHOD => 'qx', + ); + @log = grep /^r\d+/, @log; + + # Assign a sequential "version" number to each sub-directory + my $version = scalar @log; + for (@log) { + m/^r(\d+)/; + $allversions{$1} = 'v' . $version--; + } + } + my %versions = %allversions; + + # Extract only revisions matching the conditions + if (@{ $dirs{$dir} }) { + my @conditions = @{ $dirs{$dir} }; + + for my $condition (@conditions) { + for my $rev (keys %versions) { + delete $versions{$rev} unless eval ($rev . $condition); + } + } + } + + # Destination directory + my $dirpath = File::Spec->catfile ($dest, $dir); + + if (-d $dirpath) { + if ($full or not keys %versions) { + # Remove destination directory top, in full mode + # or if there are no matching revisions + &run_command ([qw/rm -rf/, $dirpath], PRINT => 1); + + } else { + # Delete excluded revisions if they exist, in incremental mode + if (opendir DIR, $dirpath) { + while (my $rev = readdir 'DIR') { + next unless $rev =~ /^\d+$/; + + if (not grep {$_ eq $rev} keys %versions) { + my @command = (qw/rm -rf/, File::Spec->catfile ($dirpath, $rev)); + &run_command (\@command, PRINT => 1); + + # Remove "version" symlink + my $verlink = File::Spec->catfile ($dirpath, $allversions{$rev}); + unlink $verlink if -l $verlink; + } + } + closedir DIR; + } + } + } + + # Create container directory of destination if it does not already exist + if (keys %versions and not -d $dirpath) { + print '-> mkdir -p ', $dirpath, "\n"; + my $rc = mkpath $dirpath; + die 'mkdir -p ', $dirpath, ' failed' unless $rc; + } + + # Update each version directory that needs updating + for my $rev (keys %versions) { + my $revpath = File::Spec->catfile ($dest, $dir, $rev); + + # Create version directory if it does not exist + if (not -e $revpath) { + # Use "svn export" to create the version directory + my @command = ( + qw/svn export -q -r/, + $rev, + join ('/', ($url, $dir)), + $revpath, + ); + + &run_command (\@command, PRINT => 1); + } + + # Create "version" symlink if necessary + my $verlink = File::Spec->catfile ($dest, $dir, $versions{$rev}); + symlink $rev, $verlink unless -l $verlink; + } + + # Symbolic link to the "latest" version directory + my $headlink = File::Spec->catfile ($dest, $dir, 'latest'); + my $headrev = 0; + for my $rev (keys %versions) { + $headrev = $rev if $rev > $headrev; + } + + if (-l $headlink) { + # Remove old symbolic link if there is no revision to update or if it + # does not point to the correct version directory + my $org = readlink $headlink; + unlink $headlink if (! $headrev or $org ne $headrev); + } + + # (Re-)create the "latest" symbolic link, if necessary + symlink $headrev, $headlink if ($headrev and not -l $headlink); + } + + $date = localtime; + print $this, ': finished normally on ', $date, "\n"; +} + +__END__ + +=head1 NAME + +fcm_update_version_dir.pl + +=head1 SYNOPSIS + + fcm_update_version_dir.pl [OPTIONS] [CFGFILE] + +=head1 DESCRIPTION + +Update the version directories for a list of relative paths in the source +repository URL. + +=head1 OPTIONS + +=over 4 + +=item --dest=DEST, -d DEST + +Specify a destination for the extraction. If not specified, the command extracts +to the current working directory. + +=item --help, -h + +Print help and exit. + +=item --full, -f + +Specify the full mode. If not specified, the command runs in incremental mode. + +=item --url=URL, -u URL + +Specify the source repository URL. No default. + +=back + +=head1 ARGUMENTS + +A configuration file may be given to this command, or it will attempt to read +from the standard input. Each line in the configuration must contain a relative +path that resides under the given source repository URL. (Empty lines and lines +beginning with a "#" are ignored.) Optionally, each relative path may be +followed by a list of space separated "conditions". Each condition is a +conditional operator (>, >=, <, <=, == or !=) followed by a revision number or +the keyword HEAD. The command uses the revision log to determine the revisions +at which the relative path has been updated in the source repository URL. If +these revisions also satisfy the "conditions" set by the user, they will be +considered in the extraction. In full mode, everything is re-extracted. In +incremental mode, the version directories are only updated if they do not +already exist. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ba/bae9b28c4ec5aa1128374dde04a709d9e60212c8.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ba/bae9b28c4ec5aa1128374dde04a709d9e60212c8.svn-base new file mode 100644 index 0000000..bccc527 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ba/bae9b28c4ec5aa1128374dde04a709d9e60212c8.svn-base @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Entry'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = 'Fcm::Keyword::Entry'; + my $entry = $class->new({key => 'key', value => 'value'}); + isa_ok($entry, $class); + is($entry->get_key(), 'key', "normal: get_key()"); + is($entry->get_value(), 'value', "normal: get_value()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/bd/bd08ee02185b8069f6c76629dc884bc3c924aa4e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/bd/bd08ee02185b8069f6c76629dc884bc3c924aa4e.svn-base new file mode 100644 index 0000000..810aadd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/bd/bd08ee02185b8069f6c76629dc884bc3c924aa4e.svn-base @@ -0,0 +1,1149 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CmUrl +# +# DESCRIPTION +# This class contains methods for manipulating a Subversion URL in a standard +# FCM project. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CmUrl; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use HTTP::Date; +use XML::DOM; + +# FCM component modules +use Fcm::Base; +use Fcm::Keyword; +use Fcm::Util qw/run_command svn_date/; + +# Special branches +our %owner_keywords = (Share => 'shared', Config => 'config', Rel => 'release'); + +# Revision pattern +my $rev_pattern = '\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}'; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_url = Fcm::CmUrl->new ([URL => $url,]); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CmUrl class. +# +# ARGUMENTS +# URL - URL of a branch +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + $self->{URL} = (exists $args{URL} ? $args{URL} : ''); + + for (qw/ANALYSED BRANCH BRANCH_LIST INFO LIST LOG LOG_RANGE PEGREV RLIST + PROJECT SUBDIR/) { + $self->{$_} = undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->url_peg; +# $cm_url->url_peg ($url); +# +# DESCRIPTION +# This method returns/sets the current URL@PEG. +# ------------------------------------------------------------------------------ + +sub url_peg { + my $self = shift; + + if (@_) { + if (! $self->{URL} or $_[0] ne $self->{URL}) { + # Re-set URL + $self->{URL} = shift; + + # Re-set essential variables + $self->{$_} = undef for (qw/ANALYSED RLIST LIST INFO LOG LOG_RANGE/); + } + } + + return $self->{URL}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_url (); +# +# DESCRIPTION +# Returns true if current url is a valid Subversion URL. +# ------------------------------------------------------------------------------ + +sub is_url { + my $self = shift; + + # This should handle URL beginning with svn://, http:// and svn+ssh:// + return ($self->url_peg =~ m#^[\+\w]+://#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->url_exists ([$rev]); +# +# DESCRIPTION +# Returns true if current url exists (at operative revision $rev) in a +# Subversion repository. +# ------------------------------------------------------------------------------ + +sub url_exists { + my ($self, $rev) = @_; + + my $exists = $self->svnlist (REV => $rev); + + return defined ($exists); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $cm_url->svninfo ([FLAG => $flag], [REV => $rev]); +# +# DESCRIPTION +# Returns the value of $flag, where $flag is a field returned by "svn info". +# (If $flag is not set, default to "URL".) Otherwise returns an empty string. +# If REV is specified, it will be used as the operative revision. +# ------------------------------------------------------------------------------ + +sub svninfo { + my $self = shift; + my %args = @_; + + my $flag = exists $args{FLAG} ? $args{FLAG} : 'URL'; + my $rev = exists $args{REV} ? $args{REV} : undef; + + $rev = ($self->pegrev ? $self->pegrev : 'HEAD') if not $rev; + + return if not $self->is_url; + + # Get "info" for the specified revision if necessary + if (not exists $self->{INFO}{$rev}) { + # Invoke "svn info" command + my @info = &run_command ( + [qw/svn info -r/, $rev, $self->url_peg], + PRINT => $self->config->verbose > 2, + METHOD => 'qx', + DEVNULL => 1, + ERROR => 'ignore', + ); + + # Store selected information + for (@info) { + chomp; + + if (/^(.+?):\s*(.+)$/) { + $self->{INFO}{$rev}{$1} = $2; + } + } + } + + my $return = exists $self->{INFO}{$rev}{$flag} + ? $self->{INFO}{$rev}{$flag} : undef; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %logs = $cm_url->svnlog ( +# [REV => $rev,] +# [REV => \@revs,] # reference to a 2-element array +# [STOP_ON_COPY => 1,] +# ); +# +# DESCRIPTION +# Returns the logs for the current URL. If REV is a range of revisions or not +# specified, return a hash where the keys are revision numbers and the values +# are the entries (which are hash references). If a single REV is specified, +# return the entry (a hash reference) at the specified REV. Each entry in the +# returned list is a hash reference, with the following structure: +# +# $entry = { +# author => $author, # the commit author +# date => $date, # the commit date (in seconds since epoch) +# msg => $msg, # the log message +# paths => { # list of changed paths +# $path1 => { # a changed path +# copyfrom-path => $frompath, # copy-from-path +# copyfrom-rev => $fromrev, # copy-from-revision +# action => $action, # action status code +# }, +# ... => { ... }, # ... more changed paths ... +# }, +# } +# ------------------------------------------------------------------------------ + +sub svnlog { + my $self = shift; + my %args = @_; + + my $stop_on_copy = exists $args{STOP_ON_COPY} ? $args{STOP_ON_COPY} : 0; + my $rev_arg = exists $args{REV} ? $args{REV} : 0; + + my @revs; + + # Get revision options + # ---------------------------------------------------------------------------- + if ($rev_arg) { + if (ref ($rev_arg)) { + # Revsion option is an array, a range of revisions specified? + ($revs [0], $revs [1]) = @$rev_arg; + + } else { + # A single revision specified + $revs [0] = $rev_arg; + } + + # Expand 'HEAD' revision + for my $rev (@revs) { + next unless uc ($rev) eq 'HEAD'; + $rev = $self->svninfo (FLAG => 'Revision', REV => 'HEAD'); + } + + } else { + # No revision option specified, get log for all revisions + $revs [0] = $self->svninfo (FLAG => 'Revision'); + $revs [1] = 1; + } + + $revs [1] = $revs [0] if not $revs [1]; + @revs = sort {$b <=> $a} @revs; + + # Check whether a "svn log" run is necessary + # ---------------------------------------------------------------------------- + my $need_update = ! ($revs [0] == $revs [1] and exists $self->{LOG}{$revs [0]}); + my @ranges = @revs; + if ($need_update and $self->{LOG_RANGE}) { + my %log_range = %{ $self->{LOG_RANGE} }; + + if ($stop_on_copy) { + $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER_SOC}; + + } else { + $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER}; + } + } + + $need_update = 0 if $ranges [0] < $ranges [1]; + + if ($need_update) { + # Invoke "svn log" command for all revisions of the current branch + # -------------------------------------------------------------------------- + my @command = ( + qw/svn log --xml -v/, ($stop_on_copy ? '--stop-on-copy' : ()), + '-r' . join (':', @ranges), + $self->url_peg, + ); + + my $rc; + my @xml = &run_command ( + \@command, + PRINT => $self->config->verbose > 2, + METHOD => 'qx', + DEVNULL => 1, + ERROR => 'ignore', + RC => \$rc, + ); + + # Parse the XML + # -------------------------------------------------------------------------- + if (not $rc) { + my $parser = XML::DOM::Parser->new; + my $doc = $parser->parse (join ('', @xml)); + + my $entry_list = $doc->getElementsByTagName ('logentry'); + + # Record the author, date, message and path change for each revision + for my $i (0 .. $entry_list->getLength - 1) { + # Select current entry from node list + my $entry = $entry_list->item ($i); + my %this = (); + + # Revision is an attribute of the entry node + my $rev = $entry->getAttributeNode ('revision')->getValue; + + # Author, date and log message are children elements of the entry node + for my $key (qw/author date msg/) { + # Get data of each node, also convert date to seconds since epoch + my $node = $entry->getElementsByTagName ($key)->item (0); + my $data = ($node and $node->getFirstChild) + ? $node->getFirstChild->getData : ''; + $this{$key} = ($key eq 'date' ? str2time ($data) : $data); + } + + # Path nodes are grand children elements of the entry node + my $paths = $entry->getElementsByTagName ('path'); + + for my $p (0 .. $paths->getLength - 1) { + # Select current path node from node list + my $node = $paths->item ($p); + + # Get data from the path node + my $path = $node->getFirstChild->getData; + $this{paths}{$path} = {}; + + # Action, copyfrom-path and copyfrom-rev are attributes of path nodes + for my $key (qw/action copyfrom-path copyfrom-rev/) { + next unless $node->getAttributeNode ($key); # ensure attribute exists + + $this{paths}{$path}{$key} = $node->getAttributeNode ($key)->getValue; + } + } + + $self->{LOG}{$rev} = \%this; + } + } + + # Update the range cache + # -------------------------------------------------------------------------- + # Upper end of the range + $self->{LOG_RANGE}{UPPER} = $ranges [0] + if ! $self->{LOG_RANGE}{UPPER} or $ranges [0] > $self->{LOG_RANGE}{UPPER}; + + # Lower end of the range, need to take into account the stop-on-copy option + if ($stop_on_copy) { + # Lower end of the range with stop-on-copy option + $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1] + if ! $self->{LOG_RANGE}{LOWER_SOC} or + $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC}; + + my $low = (sort {$a <=> $b} keys %{ $self->{LOG} }) [0]; + $self->{LOG_RANGE}{LOWER} = $low + if ! $self->{LOG_RANGE}{LOWER} or $low < $self->{LOG_RANGE}{LOWER}; + + } else { + # Lower end of the range without the stop-on-copy option + $self->{LOG_RANGE}{LOWER} = $ranges [1] + if ! $self->{LOG_RANGE}{LOWER} or + $ranges [1] < $self->{LOG_RANGE}{LOWER}; + + $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1] + if ! $self->{LOG_RANGE}{LOWER_SOC} or + $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC}; + } + } + + my %return = (); + + if (! $rev_arg or ref ($rev_arg)) { + # REV is an array, return log entries if they are within range + for my $rev (sort {$b <=> $a} keys %{ $self->{LOG} }) { + next if $rev > $revs [0] or $revs [1] > $rev; + + $return{$rev} = $self->{LOG}{$rev}; + + if ($stop_on_copy) { + last if exists $self->{LOG}{$rev}{paths}{$self->branch_path} and + $self->{LOG}{$rev}{paths}{$self->branch_path}{action} eq 'A'; + } + } + + } else { + # REV is a scalar, return log of the specified revision if it exists + %return = %{ $self->{LOG}{$revs [0]} } if exists $self->{LOG}{$revs [0]}; + } + + return %return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $cm_branch->display_svnlog ($rev, [$wiki]); +# +# DESCRIPTION +# This method returns a string for displaying the log of the current branch +# at a $rev. If $wiki is set, returns a string for displaying in a Trac wiki +# table. The value of $wiki should be the Subversion URL of a FCM project +# associated with the intended Trac system. +# ------------------------------------------------------------------------------ + +sub display_svnlog { + my ($self, $rev, $wiki) = @_; + my $return = ''; + + my %log = $self->svnlog (REV => $rev); + + if ($wiki) { + # Output in Trac wiki format + # -------------------------------------------------------------------------- + $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || '; + + my $trac_url = Fcm::Keyword::get_browser_url($self->url); + + # Get list of tickets from log + my @tickets; + while ($log{msg} =~ /(?:(\w+):)?(?:#|ticket:)(\d+)/g) { + push @tickets, [$1, $2]; + } + @tickets = sort { + if ($a->[0] and $b->[0]) { + $a->[0] cmp $b->[0] or $a->[1] <=> $b->[1]; + + } elsif ($a->[0]) { + 1; + + } else { + $a->[1] <=> $b->[1]; + } + } @tickets; + + if ($trac_url =~ m#^$wiki(?:/*|$)#) { + # URL is in the specified $wiki, use Trac link + $return .= '[' . $rev . '] ||'; + + for my $ticket (@tickets) { + $return .= ' '; + $return .= $ticket->[0] . ':' if $ticket->[0]; + $return .= '#' . $ticket->[1]; + } + + $return .= ' ||'; + + } else { + # URL is not in the specified $wiki, use full URL + my $rev_url = $trac_url; + $rev_url =~ s{/intertrac/source:.*\z}{/intertrac/changeset:$rev}xms; + $return .= '[' . $rev_url . ' ' . $rev . '] ||'; + + my $ticket_url = $trac_url; + $ticket_url =~ s{/intertrac/source:.*\z}{/intertrac/}xms; + + for my $ticket (@tickets) { + $return .= ' [' . $ticket_url; + $return .= $ticket->[0] . ':' if $ticket->[0]; + $return .= 'ticket:' . $ticket->[1] . ' ' . $ticket->[1] . ']'; + } + + $return .= ' ||'; + } + + } else { + # Output in plain text format + # -------------------------------------------------------------------------- + my @msg = split /\n/, $log{msg}; + my $line = (@msg > 1 ? ' lines' : ' line'); + + $return .= join ( + ' | ', + ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line), + ); + $return .= "\n\n"; + $return .= $log{msg}; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @list = $cm_url->svnlist ([REV => $rev], [RECURSIVE => 1]); +# +# DESCRIPTION +# The method returns a list of paths as returned by "svn list". If RECURSIVE +# is set, "svn list" is invoked with the "-R" option. +# ------------------------------------------------------------------------------ + +sub svnlist { + my $self = shift; + my %args = @_; + + my $recursive = exists $args{RECURSIVE} ? $args{RECURSIVE} : 0; + my $rev = exists $args{REV} ? $args{REV} : undef; + my $key = $recursive ? 'RLIST' : 'LIST'; + + # Find out last changed revision of the current URL + $rev = $self->svninfo (FLAG => 'Last Changed Rev', REV => $rev); + return () if not $rev; + + # Get directory listing for the current URL at the last changed revision + if (not exists $self->{$key}{$rev}) { + my $rc; + + my @list = map {chomp; $_} &run_command ( + [qw/svn list -r/, $rev, ($recursive ? '-R' : ()), $self->url_peg], + METHOD => 'qx', ERROR => 'ignore', DEVNULL => 1, RC => \$rc, + ); + + $self->{$key}{$rev} = $rc ? undef : \@list; + } + + return (defined ($self->{$key}{$rev}) ? @{ $self->{$key}{$rev} } : undef); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @list = $cm_url->branch_list ($rev); +# +# DESCRIPTION +# The method returns a list of branches in the current project, assuming the +# FCM naming convention. If $rev if specified, it returns the list of +# branches at $rev. +# ------------------------------------------------------------------------------ + +sub branch_list { + my ($self, $rev) = @_; + + # Current URL must be a valid FCM project + return if not $self->project; + + # Find out last changed revision of the current URL + $rev = $self->svninfo (FLAG => 'Revision', REV => $rev); + return () if not $rev; + + if (not exists $self->{BRANCH_LIST}{$rev}) { + $self->{BRANCH_LIST}{$rev} = []; + + # Get URL of the project "branches/" sub-directory + my $url = Fcm::CmUrl->new (URL => $self->project_url . '/branches'); + + # List three levels underneath "branches/" + # First level, i.e. dev, test, pkg, etc + my @list1 = map {$url->url . '/' . $_} $url->svnlist (REV => $rev); + @list1 = grep m#/$#, @list1; + + # Second level, i.e. user name, Shared, Rel or Config + my @list2; + for (@list1) { + my $u = Fcm::CmUrl->new (URL => $_); + my @list = $u->svnlist (REV => $rev); + + push @list2, map {$u->url . $_} @list; + } + + # Third level, branch name + for (@list2) { + my $u = Fcm::CmUrl->new (URL => $_); + my @list = map {s#/*$##; $_} $u->svnlist (REV => $rev); + + push @{ $self->{BRANCH_LIST}{$rev} }, map {$u->url . $_} @list; + } + } + + return @{ $self->{BRANCH_LIST}{$rev} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $self->_analyse_url (); +# +# DESCRIPTION +# The method analyses the current URL, breaking it up into the project +# (substring of URL up to the slash before "trunk", "branches" or "tags"), +# branch name ("trunk", "branches/<type>/<id>/<name>" or "tags/<name>") and +# the sub-directory below the top of the project sub-tree. It re-sets the +# corresponding interal variables. +# ------------------------------------------------------------------------------ + +sub _analyse_url { + my $self = shift; + my ($url, $project, $branch, $subdir, $pegrev); + + # Check that URL is set + $url = $self->url_peg; + return if not $url; + return if not $self->is_url; + + # Extract from URL the peg revision + $pegrev = $1 if $url =~ s/@($rev_pattern)$//i; + + if ($url =~ m#^(.*?)/+(trunk|branches|tags)(?:/+(.*))?/*$#) { + # URL is under the "trunk", a branch or a tag + $project = $1; + my ($branch_id, $remain) = ($2, $3); + + $remain = '' if not defined $remain; + + if ($branch_id eq 'trunk') { + # URL under the "trunk" + $branch = 'trunk'; + + } else { + # URL under a branch or a tag + $branch = $branch_id; + + # Assume "3 sub-directories", FCM branch naming convention + for (1 .. 3) { + if ($remain =~ s#^([^/]+)(?:/+|$)##) { + $branch .= '/' . $1; + + } else { + $branch = undef; + last; + } + } + } + + $subdir = $remain ? $remain : '' if $branch; + + } else { + # URL is at some level above the "trunk", a branch or a tag + # Use "svn ls" to determine whether it is a project URL + my @list = $self->svnlist (REV => ($pegrev ? $pegrev : 'HEAD')); + my %lines = map {chomp $_; ($_, 1)} @list; + + # A project URL should have the "trunk", "branches" and "tags" directories + ($project = $url) =~ s#/*$## + if $lines{'trunk/'} and $lines{'branches/'} and $lines{'tags/'}; + } + + $self->{PROJECT} = $project; + $self->{BRANCH} = $branch; + $self->{SUBDIR} = $subdir; + $self->{PEGREV} = $pegrev; + $self->{ANALYSED} = 1; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->root (); +# +# DESCRIPTION +# The method returns the repository root of the current URL. +# ------------------------------------------------------------------------------ + +sub root { + my $self = shift; + + return $self->svninfo (FLAG => 'Repository Root'); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->project_url_peg (); +# $cm_url->project_url_peg ($url); +# +# DESCRIPTION +# The method returns the URL@PEG of the "project" part of the current URL. If +# an argument is specified, the URL of the "project" part and the peg +# revision of the current URL are re-set. +# ------------------------------------------------------------------------------ + +sub project_url_peg { + my $self = shift; + + if (@_) { + my $url = shift; + + # Re-construct URL is necessary + if (! $self->project_url_peg or $url ne $self->project_url_peg) { + my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : ''; + + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $self->subdir if $self->subdir; + $url .= '@' . $pegrev if $pegrev; + + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{PROJECT} . ($self->pegrev ? '@' . $self->pegrev : ''); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->project_url (); +# $cm_url->project_url ($url); +# +# DESCRIPTION +# The method returns the URL of the "project" part of the current URL. If an +# argument is specified, the URL of the "project" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub project_url { + my $self = shift; + + if (@_) { + my $url = shift; + $url =~ s/@($rev_pattern)$//i; + + # Re-construct URL is necessary + if (! $self->project_url or $url ne $self->project_url) { + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $self->subdir if $self->subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{PROJECT}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->project_path (); +# $cm_url->project_path ($path); +# +# DESCRIPTION +# The method returns the path of the "project" part of the current URL. If an +# argument is specified, the path of the "project" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub project_path { + my $self = shift; + + # Repository root + my $root = $self->root; + $root = substr ( + $self->project_url, + 0, + length ($self->project_url) - length ($self->project) - 1 + ) if not $root; + + if (@_) { + my $path = shift; + + # Re-construct URL is necessary + if (! $self->project_path or $path ne $self->project_path) { + $path .= '/' . $self->branch if $self->branch; + $path .= '/' . $self->subdir if $self->subdir; + + $self->path ($path); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return substr ($self->{PROJECT}, length ($root)); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $name = $cm_url->project (); +# $cm_url->project ($name); +# +# DESCRIPTION +# The method returns the basename of the "project" part of the current URL. +# If an argument is specified, the basename of the "project" part of the +# current URL is re-set. +# ------------------------------------------------------------------------------ + +sub project { + my $self = shift; + + if (@_) { + my $name = shift; + + # Re-construct URL is necessary + if (! $self->project or $name ne $self->project) { + my $url = ''; + if ($self->project) { + $url = $self->project; + $url =~ s#/[^/]+$##; + + } else { + $url = $self->root; + } + + $url .= '/' . $name; + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $self->subdir if $self->subdir; + $url .= '@' . $self->pegrev if $self->pegrev; + + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + my $name = $self->{PROJECT}; + $name =~ s#^.*/([^/]+)$#$1# if $name; + + return $name; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->branch_url_peg (); +# $cm_url->branch_url_peg ($url); +# +# DESCRIPTION +# The method returns the URL@PEG of the "branch" part of the current URL. If +# an argument is specified, the URL@PEG of the "branch" part of the current +# URL is re-set. +# ------------------------------------------------------------------------------ + +sub branch_url_peg { + my $self = shift; + + if (@_) { + my $url = shift; + + # Re-construct URL is necessary + if (! $self->branch_url_peg or $url ne $self->branch_url_peg) { + my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : ''; + + $url .= '/' . $self->subdir if $self->subdir; + $url .= '@' . $pegrev if $pegrev; + + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->project_url . '/' . $self->branch . + ($self->pegrev ? '@' . $self->pegrev : ''); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->branch_url (); +# $cm_url->branch_url ($url); +# +# DESCRIPTION +# The method returns the URL of the "branch" part of the current URL. If an +# argument is specified, the URL of the "branch" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub branch_url { + my $self = shift; + + if (@_) { + my $url = shift; + $url =~ s/@($rev_pattern)$//i; + + # Re-construct URL is necessary + if (! $self->branch_url or $url ne $self->branch_url) { + $url .= '/' . $self->subdir if $self->subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->project_url . '/' . $self->branch; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->branch_path (); +# $cm_url->branch_path ($path); +# +# DESCRIPTION +# The method returns the path of the "branch" part of the current URL. If an +# argument is specified, the path of the "branch" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub branch_path { + my $self = shift; + + if (@_) { + my $path = shift; + + # Re-construct URL is necessary + if (! $self->branch_path or $path ne $self->branch_path) { + $path .= '/' . $self->subdir if $self->subdir; + + $self->path ($path); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch ? $self->project_path . '/' . $self->branch : undef); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $branch = $cm_url->branch (); +# $cm_url->branch ($branch); +# +# DESCRIPTION +# The method returns the "branch" part of the current URL. If an argument is +# specified, the "branch" part of the current URL is re-set. +# ------------------------------------------------------------------------------ + +sub branch { + my $self = shift; + + if (@_) { + my $branch = shift; + + # Re-construct URL is necessary + if (! $self->branch or $branch ne $self->branch) { + my $url = $self->project_url; + $url .= '/' . $branch; + $url .= '/' . $self->subdir if $self->subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{BRANCH}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->branch_owner; +# +# DESCRIPTION +# This method returns the owner of the branch. +# ------------------------------------------------------------------------------ + +sub branch_owner { + my $self = shift; + my $return; + + if ($self->is_branch and $self->branch_url =~ m#/([^/]+)/[^/]+/*$#) { + my $user = $1; + $return = $user; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_trunk (); +# +# DESCRIPTION +# The method returns true if the the current URL is (a sub-tree of) the trunk. +# ------------------------------------------------------------------------------ + +sub is_trunk { + my $self = shift; + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch and $self->branch eq 'trunk'); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_branch (); +# +# DESCRIPTION +# The method returns true if the the current URL is (a sub-tree of) a branch. +# ------------------------------------------------------------------------------ + +sub is_branch { + my $self = shift; + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch and $self->branch =~ m#^branches/#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_tag (); +# +# DESCRIPTION +# The method returns true if the the current URL is (a sub-tree of) a tag. +# ------------------------------------------------------------------------------ + +sub is_tag { + my $self = shift; + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch and $self->branch =~ m#^tags/#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $subdir = $cm_url->subdir (); +# $cm_url->subdir ($subdir); +# +# DESCRIPTION +# The method returns the "subdir" part of the current URL. If an argument is +# specified, the "subdir" part of the current URL is re-set. +# ------------------------------------------------------------------------------ + +sub subdir { + my $self = shift; + + if (@_) { + my $subdir = shift; + + # Re-construct URL is necessary + if (! $self->subdir or $subdir ne $self->subdir) { + my $url = $self->project_url; + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $subdir if $subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{SUBDIR}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->url (); +# $cm_url->url ($url); +# +# DESCRIPTION +# The method returns the URL without the "peg revision" part. If an argument +# is specified, the URL is re-set without modifying the "peg revision" part. +# ------------------------------------------------------------------------------ + +sub url { + my $self = shift; + + if (@_) { + my $url = shift; + $url =~ s/@($rev_pattern)$//i; + + # Re-construct URL if necessary + if (! $self->url or $url ne $self->url) { + $self->url_peg ($url . ($self->pegrev ? '@' . $self->pegrev : '')); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + (my $url = $self->url_peg) =~ s/@($rev_pattern)$//i; + + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->path (); +# $cm_url->path ($path); +# +# DESCRIPTION +# The method returns the "path" part of the URL (i.e. URL without the +# "root" part). If an argument is specified, the "path" part of the URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub path { + my $self = shift; + + # Repository root + my $root = $self->root; + $root = substr ( + $self->project_url, + 0, + length ($self->project_url) - length ($self->project) - 1 + ) if not $root; + + if (@_) { + my $path = shift; + $path =~ s/@($rev_pattern)$//i; + + # Re-construct URL is necessary + if (! $self->path or $path ne $self->path) { + my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path); + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return substr ($self->url, length ($root)); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->path_peg (); +# $cm_url->path_peg ($path); +# +# DESCRIPTION +# The method returns the PATH@PEG part of the URL (i.e. URL without the +# "root" part). If an argument is specified, the PATH@PEG part of the URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub path_peg { + my $self = shift; + + # Repository root + my $root = $self->root; + $root = substr ( + $self->project_url, + 0, + length ($self->project_url) - length ($self->project) - 1 + ) if not $root; + + if (@_) { + my $path = shift; + + # Re-construct URL is necessary + if (! $self->path_peg or $path ne $self->path_peg) { + my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path); + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return substr ($self->url_peg, length ($root)); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $cm_url->pegrev (); +# $cm_url->pegrev ($rev); +# +# DESCRIPTION +# The method returns the "peg revision" part of the current URL. If an +# argument is specified, the "peg revision" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub pegrev { + my $self = shift; + + if (@_) { + my $pegrev = shift; + + # Re-construct URL is necessary + if (! $self->pegrev or $pegrev ne $self->pegrev) { + $self->url_peg ($self->url . ($pegrev ? '@' . $pegrev : '')); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{PEGREV}; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/be/bedf760bd022824c4aac360c88be2fed5c9f61c8.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/be/bedf760bd022824c4aac360c88be2fed5c9f61c8.svn-base new file mode 100644 index 0000000..b5f886e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/be/bedf760bd022824c4aac360c88be2fed5c9f61c8.svn-base @@ -0,0 +1,340 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::BuildTask +# +# DESCRIPTION +# This class hosts information of a build task in the FCM build system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::BuildTask; +@ISA = qw(Fcm::Base); + +# Standard pragma +use strict; +use warnings; + +# Standard modules +use Carp; +use File::Compare; +use File::Copy; +use File::Basename; +use File::Path; +use File::Spec::Functions; + +# FCM component modules +use Fcm::Base; +use Fcm::Timer; +use Fcm::Util; + +# List of property methods for this class +my @scalar_properties = ( + 'actiontype', # type of action + 'dependency', # list of dependencies for this target + 'srcfile', # reference to input Fcm::BuildSrc instance + 'output', # output file + 'outputmtime', # output file modification time + 'target', # target name for this task + 'targetpath', # search path for the target +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::BuildTask->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::BuildTask class. See +# above for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + bless $self, $class; + + for my $name (@scalar_properties) { + $self->{$name} = exists $args{uc ($name)} ? $args{uc ($name)} : undef; + } + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + + if ($name eq 'output') { + $self->{outputmtime} = $_[0] ? (stat $_[0]) [9] : undef; + } + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'dependency' or $name eq 'targetpath') { + # Reference to an array + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->action (TASKLIST => \%tasklist); +# +# DESCRIPTION +# This method performs the task action and sets the output accordingly. The +# argument TASKLIST must be a reference to a hash containing the other tasks +# of the build, which this task may depend on. The keys of the hash must the +# name of the target names of the tasks, and the values of the hash must be +# the references to the corresponding Fcm::BuildTask instances. The method +# returns true if the task has been performed to create a new version of the +# target. +# ------------------------------------------------------------------------------ + +sub action { + my $self = shift; + my %args = @_; + my $tasklist = exists $args{TASKLIST} ? $args{TASKLIST} : {}; + + return unless $self->actiontype; + + my $uptodate = 1; + my $dep_uptodate = 1; + + # Check if dependencies are up to date + # ---------------------------------------------------------------------------- + for my $depend (@{ $self->dependency }) { + if (exists $tasklist->{$depend}) { + if (not $tasklist->{$depend}->output) { + # Dependency task output is not set, performs its task action + if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) { + $uptodate = 0; + $dep_uptodate = 0; + } + } + + } elsif ($self->verbose > 1) { + w_report 'Warning: Task for "', $depend, + '" does not exist, may be required by ', $self->target; + } + } + + # Check if the target exists in the search path + # ---------------------------------------------------------------------------- + if (@{ $self->targetpath }) { + my $output = find_file_in_path ($self->target, $self->targetpath); + $self->output ($output) if $output; + } + + # Target is out of date if it does not exist + if ($uptodate) { + $uptodate = 0 if not $self->output; + } + + # Check if current target is older than its dependencies + # ---------------------------------------------------------------------------- + if ($uptodate) { + for my $depend (@{ $self->dependency }) { + next unless exists $tasklist->{$depend}; + + if ($tasklist->{$depend}->outputmtime > $self->outputmtime) { + $uptodate = 0; + $dep_uptodate = 0; + } + } + + if ($uptodate and ref $self->srcfile) { + $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime; + } + } + + if ($uptodate) { + # Current target and its dependencies are up to date + # -------------------------------------------------------------------------- + if ($self->actiontype eq 'PP') { + # "done" file up to date, set name of pre-processed source file + # ------------------------------------------------------------------------ + my $base = $self->srcfile->root . lc ($self->srcfile->ext); + my @pknames = split '__', (@{ $self->srcfile->pkgnames })[-2]; + my @path = map { + catfile ($_, @pknames); + } @{ $self->setting (qw/PATH PPSRC/) }; + my $oldfile = find_file_in_path ($base, \@path); + $self->srcfile->ppsrc ($oldfile); + } + + } else { + # Perform action is not up to date + # -------------------------------------------------------------------------- + # (For GENINTERFACE and PP, perform action if "done" file not up to date) + my $new_output = @{ $self->targetpath } + ? catfile ($self->targetpath->[0], $self->target) + : $self->target; + + # Create destination container directory if necessary + my $destdir = dirname $new_output; + + if (not -d $destdir) { + print 'Make directory: ', $destdir, "\n" if $self->verbose > 2; + mkpath $destdir; + } + + # List of actions + if ($self->actiontype eq 'UPDATE') { + # Action is UPDATE: Update file + # ------------------------------------------------------------------------ + print 'Update: ', $new_output, "\n" if $self->verbose > 2; + touch_file $new_output + or croak 'Unable to update "', $new_output, '", abort'; + $self->output ($new_output); + + } elsif ($self->actiontype eq 'COPY') { + # Action is COPY: copy file to destination if necessary + # ------------------------------------------------------------------------ + my $copy_required = ($dep_uptodate and $self->output and -r $self->output) + ? compare ($self->output, $self->srcfile->src) + : 1; + + if ($copy_required) { + # Set up copy command + my $srcfile = $self->srcfile->src; + my $destfile = catfile ($destdir, basename($srcfile)); + print 'Copy: ', $srcfile, "\n", ' to: ', $destfile, "\n" + if $self->verbose > 2; + © ($srcfile, $destfile) + or die $srcfile, ': copy to ', $destfile, ' failed (', $!, '), abort'; + chmod (((stat ($srcfile))[2] & 07777), $destfile); + + $self->output ($new_output); + + } else { + $uptodate = 1; + } + + } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') { + # Action is PP or GENINTERFACE: process file + # ------------------------------------------------------------------------ + my ($newlines, $base, @path); + + if ($self->actiontype eq 'PP') { + # Invoke the pre-processor on the source file + # ---------------------------------------------------------------------- + # Get lines in the pre-processed source + $newlines = $self->srcfile->get_pre_process; + $base = $self->srcfile->root . lc ($self->srcfile->ext); + + # Get search path for the existing pre-processed file + my @pknames = split '__', (@{ $self->srcfile->pkgnames })[-2]; + @path = map { + catfile ($_, @pknames); + } @{ $self->setting (qw/PATH PPSRC/) }; + + } else { # if ($self->actiontype eq 'GENINTERFACE') + # Invoke the interface generator + # ---------------------------------------------------------------------- + # Get new interface lines + $newlines = $self->srcfile->get_fortran_interface; + + # Get search path for the existing interface file + $base = $self->srcfile->interfacebase; + @path = @{ $self->setting (qw/PATH INC/) }, + } + + + # If pre-processed or interface file exists, + # compare its content with new lines to see if it has been updated + my $update_required = 1; + my $oldfile = find_file_in_path ($base, \@path); + + if ($oldfile and -r $oldfile) { + # Read old file + open FILE, '<', $oldfile; + my @oldlines = readline 'FILE'; + close FILE; + + # Compare old contents and new contents + if (@oldlines eq @$newlines) { + $update_required = grep { + $oldlines[$_] ne $newlines->[$_]; + } (0 .. $#oldlines); + } + } + + if ($update_required) { + # Update the pre-processed source or interface file + # ---------------------------------------------------------------------- + # Determine container directory of the pre-processed or interface file + my $newfile = @path ? catfile ($path[0], $base) : $base; + + # Create the container directory if necessary + if (not -d $path[0]) { + print 'Make directory: ', $path[0], "\n" + if $self->verbose > 1; + mkpath $path[0]; + } + + # Update the pre-processor or interface file + open FILE, '>', $newfile + or croak 'Cannot write to "', $newfile, '" (', $!, '), abort'; + print FILE @$newlines; + close FILE + or croak 'Cannot write to "', $newfile, '" (', $!, '), abort'; + print 'Generated: ', $newfile, "\n" if $self->verbose > 1; + + # Set the name of the pre-processed file + $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP'; + + } else { + # Content in pre-processed source or interface file is up to date + # ---------------------------------------------------------------------- + $uptodate = 1; + + # Set the name of the pre-processed file + $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP'; + } + + # Update the "done" file + print 'Update: ', $new_output, "\n" if $self->verbose > 2; + touch_file $new_output + or croak 'Unable to update "', $new_output, '", abort'; + $self->output ($new_output); + + } else { + carp 'Action type "', $self->actiontype, "' not supported"; + } + } + + return not $uptodate; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/bf/bfc457ea2075023dfd34e9b90b9ff646d9a44384.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/bf/bfc457ea2075023dfd34e9b90b9ff646d9a44384.svn-base new file mode 100644 index 0000000..0f79b00 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/bf/bfc457ea2075023dfd34e9b90b9ff646d9a44384.svn-base @@ -0,0 +1,86 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::CLI::Config::Default; +use Fcm::CLI::Subcommand; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Config'; + use_ok($class); + test_get_instance($class); + test_get_subcommand_of_string($class); +} + +################################################################################ +# Tests normal usage of getting an instance +sub test_get_instance { + my ($class) = @_; + my $prefix = 'constructor'; + my $cli_config = $class->instance(); + isa_ok($cli_config, $class, "$prefix"); + is_deeply( + [$cli_config->get_core_subcommands()], + \@Fcm::CLI::Config::Default::CORE_SUBCOMMANDS, + "$prefix: default core", + ); + is_deeply( + [$cli_config->get_vc_subcommands()], + \@Fcm::CLI::Config::Default::VC_SUBCOMMANDS, + "$prefix: default vc", + ); + is_deeply( + [$cli_config->get_subcommands()], + [$cli_config->get_core_subcommands(), $cli_config->get_vc_subcommands()], + "$prefix: default", + ); + is($class->instance(), $cli_config, "$prefix: same instance"); + isnt($class->instance({}), $cli_config, "$prefix: not the same instance"); + my $empty_cli_config = $class->instance({ + core_subcommands => [], + vc_subcommands => [], + }); + is_deeply( + [$empty_cli_config->get_core_subcommands()], + [], + "$prefix: empty core", + ); + is_deeply( + [$empty_cli_config->get_vc_subcommands()], + [], + "$prefix: empty vc", + ); + is_deeply( + [$empty_cli_config->get_subcommands()], + [], + "$prefix: empty", + ); +} + +################################################################################ +# Tests getting a subcommand of a matching string +sub test_get_subcommand_of_string { + my ($class) = @_; + my $prefix = 'get_subcommand_of'; + my $foo_subcommand = Fcm::CLI::Subcommand->new({names => ['food', 'foo']}); + my $bar_subcommand = Fcm::CLI::Subcommand->new({names => ['barley', 'bar']}); + my $cli_config = $class->instance({ + core_subcommands => [$foo_subcommand, $bar_subcommand], + vc_subcommands => [], + }); + for my $key ('food', 'foo') { + is($cli_config->get_subcommand_of($key), $foo_subcommand, + "$prefix: $key"); + } + for my $key ('barley', 'bar') { + is($cli_config->get_subcommand_of($key), $bar_subcommand, + "$prefix: $key"); + } + is($cli_config->get_subcommand_of('baz'), undef, "$prefix: baz"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c0/c01875485e06471b655f999491f1ed09a8d4de0b.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c0/c01875485e06471b655f999491f1ed09a8d4de0b.svn-base new file mode 100644 index 0000000..36976a2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c0/c01875485e06471b655f999491f1ed09a8d4de0b.svn-base @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my ($class) = 'Fcm::Keyword::Entry::Location'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + isa_ok($class->new(), $class, "$prefix: empty"); + my $entry = $class->new({key => 'key', value => 'value'}); + isa_ok($entry, $class, "$prefix: normal"); + is($entry->get_key(), 'key', "$prefix: normal: get_key()"); + is($entry->get_value(), 'value', "$prefix: normal: get_value()"); + isa_ok($entry->get_revision_entries(), 'Fcm::Keyword::Entries'); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c0/c07d5c616a5f8002bc88cb08d6fc661b4c0cd175.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c0/c07d5c616a5f8002bc88cb08d6fc661b4c0cd175.svn-base new file mode 100644 index 0000000..ad5ecea --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c0/c07d5c616a5f8002bc88cb08d6fc661b4c0cd175.svn-base @@ -0,0 +1,35 @@ +.\" Process this file with +.\" groff -man -Tascii fcm.1 +.\" +.TH fcm 1 "" "" "User Commands" +.SH NAME +fcm - command line client for the Flexible Configuration Management system +.SH SYNOPSIS +.B fcm +.I command +[ +.I options +] [ +.I args +] +.SH OVERVIEW +.B fcm +is the command line client for code management commands, the extract system and +the build system of the Flexible Configuration Management (FCM) system. +For full detail of the system, please refer to the FCM user guide, which you +should receive with this distribution in both HTML and PDF formats. +.PP +Run "fcm help" to access the built-in tool documentation. +.SH AUTHOR +FCM Team <fcm-team@metoffice.gov.uk>. +Please feedback any bug reports or feature requests to us by e-mail. +.SH COPYRIGHT +British Crown Copyright \(co Met Office. All rights reserved. +.PP +You can use this release of +.B FCM +freely under the terms of the FCM LICENSE, +which you should receive with this distribution. +.SH SEE ALSO +.BR svn (1), +.BR perl (1) diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c2/c28db31a94de0462990b4fa4273824840e2fc4bc.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c2/c28db31a94de0462990b4fa4273824840e2fc4bc.svn-base new file mode 100644 index 0000000..9928009 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c2/c28db31a94de0462990b4fa4273824840e2fc4bc.svn-base @@ -0,0 +1,83 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +my ($base, $mine, $older, $yours) = @ARGV; + +# FCM_GRAPHIC_MERGE is the graphical merge tool command +my $cmd = (exists $ENV{FCM_GRAPHIC_MERGE} ? $ENV{FCM_GRAPHIC_MERGE} : 'xxdiff'); + +my $rc = 2; +my $out = ''; +if ($cmd eq 'xxdiff') { + # Launch xxdiff + my @command = ($cmd, qw/-m -M/, $base, qw/-O -X/, $mine, $older, $yours); + my ($cmd_out) = qx(@command); + my $cmd_rc = $?; + + # Parse output from xxdiff + if ($cmd_out) { + chomp $cmd_out; + if ($cmd_out eq 'NODECISION') { + $out = 'made no decision'; + $rc = 1; + + } elsif ($cmd_out eq 'MERGED' and $cmd_rc) { + $out = 'not resolved all the conflicts'; + $rc = 1; + + } else { + $out = lc ($cmd_out); + $rc = 0; + } + + } else { + print STDERR $cmd, ': failed, abort.', "\n"; + } + +} else { + # Throw error for unknown/undefined graphic merge tool + print STDERR ($cmd ? $cmd . ': ' : ''), + 'unknown/undefined graphic merge tool, abort.', "\n"; +} + +if ($rc == 1) { + # Merge unresolved + print 'You have ', $out, '.', "\n"; + +} elsif ($rc == 0) { + # Merge resolved + print 'You ', $out, ' all the changes.', "\n"; +} + +exit $rc; + +__END__ + +=head1 NAME + +fcm_graphic_merge + +=head1 SYNOPSIS + + fcm_graphic_merge BASE MINE OLDER YOURS + +=head1 DESCRIPTION + +Wrapper script which invokes a graphical merge tool. It returns 0 on +success, 1 if conflicts not resolved or 2 on failure. (This is similar to +GNU diff3.) BASE is the file you want to save the merge result into. MINE +is the original file. YOURS is the file you want MINE to merge with. OLDER +is the common ancestor of MINE and YOURS. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c6/c6a3d577eecab17625dd61ddf4781b1feb7eacff.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c6/c6a3d577eecab17625dd61ddf4781b1feb7eacff.svn-base new file mode 100644 index 0000000..fdf22bc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/c6/c6a3d577eecab17625dd61ddf4781b1feb7eacff.svn-base @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::Help'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/cd/cdea00381bd671ecf42ad66180ec7ff210435d50.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/cd/cdea00381bd671ecf42ad66180ec7ff210435d50.svn-base new file mode 100644 index 0000000..ae28d0d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/cd/cdea00381bd671ecf42ad66180ec7ff210435d50.svn-base @@ -0,0 +1,237 @@ +#!/usr/bin/perl + +use strict; +use warnings; + + +################################################################################ +# A sub-class of Fcm::CLI::Invoker for testing +{ + package TestInvoker; + use base qw{Fcm::CLI::Invoker}; + + our $LATEST_INSTANCE; + + ############################################################################ + # Returns a test attrib + sub get_test_attrib { + my ($self) = @_; + return $self->{test_attrib}; + } + + ############################################################################ + # Invokes the sub-system + sub invoke { + my ($self) = @_; + $LATEST_INSTANCE = $self; + } +} + +use Fcm::CLI::Config; +use Fcm::CLI::Subcommand; +use Test::More (tests => 25); + +main(); + +sub main { + use_ok('Fcm::CLI'); + test_invalid_subcommand(); + test_invoker_not_implemented(); + test_normal_invoke(); + test_help_invoke(); + test_get_invoker_normal(); + test_load_invoker_class(); +} + +################################################################################ +# Tests to ensure that an invalid subcommand results in an exception +sub test_invalid_subcommand { + Fcm::CLI::Config->instance({core_subcommands => [], vc_subcommands => []}); + eval { + local(@ARGV) = ('foo'); + Fcm::CLI::invoke(); + }; + like($@, qr{foo: unknown command}, 'invalid subcommand'); +} + +################################################################################ +# Tests to ensure that an unimplemented invoker results in an exception +sub test_invoker_not_implemented { + Fcm::CLI::Config->instance({ + core_subcommands => [ + Fcm::CLI::Subcommand->new({names => ['foo']}), + Fcm::CLI::Subcommand->new({ + names => ['bar'], invoker_class => 'barley', + }), + ], + vc_subcommands => [], + }); + eval { + local(@ARGV) = ('foo'); + Fcm::CLI::invoke(); + }; + like($@, qr{foo: \s command \s not \s implemented}xms, 'not implemented'); + eval { + local(@ARGV) = ('bar'); + Fcm::CLI::invoke(); + }; + like($@, qr{barley: \s class \s loading \s failed}xms, 'not implemented'); +} + +################################################################################ +# Tests normal usage of invoke +sub test_normal_invoke { + my $prefix = "normal invoke"; + Fcm::CLI::Config->instance({ + core_subcommands => [ + Fcm::CLI::Subcommand->new({ + names => ['foo'], + invoker_class => 'TestInvoker', + invoker_config => {test_attrib => 'test_attrib value'}, + }), + ], + vc_subcommands => [], + }); + ok(!$TestInvoker::LATEST_INSTANCE, "$prefix: invoker not called"); + local(@ARGV) = ('foo', 'bar', 'baz'); + Fcm::CLI::invoke(); + my $invoker = $TestInvoker::LATEST_INSTANCE; + if (!$invoker) { + fail($prefix); + } + else { + is($invoker->get_command(), 'foo', "$prefix: invoker command"); + is_deeply({$invoker->get_options()}, {}, "$prefix: invoker options"); + is_deeply([$invoker->get_arguments()], ['bar', 'baz'], + "$prefix: invoker arguments"); + is($invoker->get_test_attrib(), 'test_attrib value', + "$prefix: invoker test attrib"); + } + $TestInvoker::LATEST_INSTANCE = undef; +} + +################################################################################ +# Tests help usage of invoke +sub test_help_invoke { + my $prefix = "help invoke"; + Fcm::CLI::Config->instance({ + core_subcommands => [ + Fcm::CLI::Subcommand->new({ + names => ['foo'], + invoker_class => 'TestInvoker', + invoker_config => {test_attrib => 'test_attrib value normal'}, + options => [ + Fcm::CLI::Option->new({name => 'foo', is_help => 1}), + ], + }), + Fcm::CLI::Subcommand->new({ + names => [q{}], + invoker_class => 'TestInvoker', + }), + ], + vc_subcommands => [], + }); + ok(!$TestInvoker::LATEST_INSTANCE, "$prefix: invoker not called"); + local(@ARGV) = ('foo', '--foo'); + Fcm::CLI::invoke(); + my $invoker = $TestInvoker::LATEST_INSTANCE; + if (!$invoker) { + fail($prefix); + } + else { + is_deeply([$invoker->get_arguments()], ['foo'], + "$prefix: invoker argument"); + } + $TestInvoker::LATEST_INSTANCE = undef; +} + +################################################################################ +# Tests getting an invoker +sub test_get_invoker_normal { + my $prefix = 'get invoker normal'; + my @options = ( + Fcm::CLI::Option->new({name => 'foo'}), + Fcm::CLI::Option->new({name => 'bar'}), + Fcm::CLI::Option->new({name => 'baz'}), + Fcm::CLI::Option->new({ + name => q{pork}, + delimiter => q{,}, + has_arg => Fcm::CLI::Option->ARRAY_ARG, + }), + ); + my $subcommand = Fcm::CLI::Subcommand->new({options => \@options}); + my %TEST = ( + test1 => { + argv => ['--foo', '--bar', 'egg', 'ham', 'sausage'], + command => 'command', + options => {foo => 1, bar => 1}, + arguments => ['egg', 'ham', 'sausage'], + }, + test2 => { + argv => ['--baz', '--foo', '--bar'], + command => 'test', + options => {foo => 1, bar => 1, baz => 1}, + arguments => [], + }, + test3 => { + argv => ['egg', 'ham', 'sausage'], + command => 'meal', + options => {}, + arguments => ['egg', 'ham', 'sausage'], + }, + test4 => { + argv => ['--pork', 'ham', '--pork', 'sausage'], + command => 'pig', + options => {pork => ['ham', 'sausage']}, + arguments => [], + }, + test5 => { + argv => ['--pork', 'ham,sausage', '--pork', 'bacon', 'liver'], + command => 'pig', + options => {pork => ['ham', 'sausage', 'bacon']}, + arguments => ['liver'], + }, + ); + for my $key (keys(%TEST)) { + local(@ARGV) = @{$TEST{$key}{argv}}; + my ($opts_ref, $args_ref) = Fcm::CLI::_parse_argv_using($subcommand); + is_deeply($opts_ref, $TEST{$key}{options}, + "$prefix $key: get options"); + is_deeply($args_ref, $TEST{$key}{arguments}, + "$prefix $key: get arguments"); + } + my %BAD_TEST = ( + test1 => { + argv => ['--egg', '--bar', 'foo', 'ham', 'sausage'], + }, + test2 => { + argv => ['--foo=egg'], + }, + ); + for my $key (keys(%BAD_TEST)) { + local(@ARGV) = @{$BAD_TEST{$key}{argv}}; + eval { + Fcm::CLI::_parse_argv_using($subcommand); + }; + isa_ok($@, 'Fcm::CLI::Exception', "$prefix $key"); + } +} + +################################################################################ +# Tests loading an invoker with a different class +sub test_load_invoker_class { + my $prefix = 'get invoker class'; + eval { + my $subcommand = Fcm::CLI::Subcommand->new({invoker_class => 'foo'}); + Fcm::CLI::_load_invoker_class_of($subcommand); + }; + isa_ok($@, 'Fcm::Exception', "$prefix"); + + my $invoker_class = 'Fcm::CLI::Invoker::ConfigSystem'; + my $subcommand + = Fcm::CLI::Subcommand->new({invoker_class => $invoker_class}); + my $class = Fcm::CLI::_load_invoker_class_of($subcommand); + is($class, $invoker_class, "$prefix: $invoker_class"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d0/d0ec9dba4d10f32c7f7110fc85906e967f49a6e4.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d0/d0ec9dba4d10f32c7f7110fc85906e967f49a6e4.svn-base new file mode 100644 index 0000000..9bbd028 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d0/d0ec9dba4d10f32c7f7110fc85906e967f49a6e4.svn-base @@ -0,0 +1,211 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Entries; + +use Carp qw{croak}; +use Fcm::Util::ClassLoader; + +sub new { + my ($class, $args_ref) = @_; + return bless( + { + entry_class => 'Fcm::Keyword::Entry', + entry_by => {key => {}, value => {}}, + has_loaded_entries_from => {}, + loaders => [], + ($args_ref && ref($args_ref) eq 'HASH' ? %{$args_ref} : ()), + }, + $class, + ); +} + +################################################################################ +# Returns the class of entries stored by this entries list +sub get_entry_class { + my ($self) = @_; + return $self->{entry_class}; +} + +################################################################################ +# Returns all entries +sub get_all_entries { + my ($self) = @_; + if (!%{$self->{entry_by}{key}}) { + # Nothing set, attempt to load entries + $self->load_entries(); + } + if (wantarray()) { + return values(%{$self->{entry_by}{key}}); + } + else { + return [values(%{$self->{entry_by}{key}})]; + } +} + +################################################################################ +# Methods: get_entry_by_* +for my $name ( + ### Returns an entry with a matching key + 'key', + ### Returns an entry with a matching value + 'value' +) { + no strict qw{refs}; + my $method = "get_entry_by_$name"; + *$method = sub { + my ($self, $search_key) = @_; + if (!defined($search_key)) { + return; + } + my $sk = ($name eq 'key') ? uc($search_key) : $search_key; + if (!exists($self->{entry_by}{$name}{$sk})) { + $self->load_entries($name, $sk); + } + if (exists($self->{entry_by}{$name}{$sk})) { + return $self->{entry_by}{$name}{$sk}; + } + else { + return; + } + } +} + +################################################################################ +# Adds an entry +sub add_entry { + my ($self, $key, $value, $args_ref) = @_; + Fcm::Util::ClassLoader::load($self->get_entry_class()); + my $entry = $self->get_entry_class()->new({ + key => uc($key), + value => $value, + ($args_ref && ref($args_ref) eq 'HASH' ? %{$args_ref} : ()), + }); + $self->{entry_by}{key}{uc($key)} = $entry; + $self->{entry_by}{value}{$value} = $entry; + return $entry; +} + +################################################################################ +# Returns the loaders for this entries list +sub get_loaders { + my ($self) = @_; + return (wantarray() ? @{$self->{loaders}} : $self->{loaders}); +} + +################################################################################ +# Loads entries using its loaders +sub load_entries { + my ($self, $name, $search_key) = @_; + LOADER: + for my $loader ($self->get_loaders()) { + if ($self->{has_loaded_entries_from}{$loader->get_source()}) { + next LOADER; + } + $self->{has_loaded_entries_from}{$loader->get_source()} + = $loader->load_to($self); + if ($name && exists($self->{entry_by}{$name}{$search_key})) { + last LOADER; + } + } +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Entries + +=head1 SYNOPSIS + + use Fcm::Keyword::Entries; + + my $entries = Fcm::Keyword::Entries->new({ + entry_class => $entry_class, + loaders => \@loaders, + }); + $entry = $entries->get_entry_by_key($key); + $entry = $entries->get_entry_by_value($value); + + for my $entry ($entries->get_entries()) { + # ... + } + + $entries->add_entry($key, $value); + +=head1 DESCRIPTION + +This module is used to manipulate FCM keyword entries. It is used by +L<Fcm::Keyword|Fcm::Keyword> to store keyword entries, which are +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> objects. + +=head1 METHODS + +=over 4 + +=item C<new({entry_class =E<gt> $entry_class, loaders =E<gt> \@loaders})> + +Constructor. The argument should be a reference to hash, where: + +I<entry_class> is a string representing the class name of entries in this +object. The class must be a sub-class of +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>. The default is +"L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>". + +I<loaders> is a reference to an array of +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader> objects, which will be used to +load entries into this object. The default is an empty array. + +=item add_entry($key,$value) + +Adds an entry. Returns the added entry. (Keys are converted to uppercases +automatically.) + +=item get_all_entries() + +Returns all entries that are currently loaded. + +=item get_entry_by_key($key) + +Return an entry, whose key matches $key. (Search is case-insensitive.) Returns +undef if there is no matching entry. + +=item get_entry_by_value($value) + +Return an entry, whose value matches $value. (Search is case-sensitive.) +Returns undef if there is no matching entry. + +=item get_loaders() + +Returns the loaders for loading entries. + +=item load_entries() + +Loads entries from its loaders, as returned by get_loaders(). This method can +also be triggered by get_all_entries(), if the entry list is empty, or by +get_entry_by_key($key) and get_entry_by_value($value) methods, if there is no +matching entry in the current lookup lists. + +=back + +=head1 TO DO + +Handle duplicated entries in add_entry($key,$value). + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d1/d10292935ab16a2ef4c36ef985665f9ac5adf2f9.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d1/d10292935ab16a2ef4c36ef985665f9ac5adf2f9.svn-base new file mode 100644 index 0000000..29168d9 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d1/d10292935ab16a2ef4c36ef985665f9ac5adf2f9.svn-base @@ -0,0 +1,79 @@ +=head1 NAME + +fcm diff (di) + +=head1 SYNOPSIS + + 1. fcm diff --branch [OPTIONS] [TARGET] + 2. fcm diff [OPTIONS] [ARGS] + +=over 4 + +=item 1. + +Show differences relative to the base of the target branch, i.e. the changes +available for merging from the target branch into its parent. If TARGET is +specified, it must either be a URL or a working copy. Otherwise, the target is +the the current directory which must be a working copy. The target URL must be a +branch in a standard FCM project. + +=item 2. + +See description of "L<svn|svn> diff" below. + +=back + +=head1 OPTIONS + +Valid options with --branch: + +=over 4 + +=item --diff-cmd arg + +As described below in the help for "L<svn|svn> diff". + +=item -g [--graphical] + +As described below. + +=item --summarise + +As described below + +=item --summarize + +As described below in the help for "L<svn|svn> diff". + +=item -t [--trac] + +If TARGET is a URL, use Trac to display the diff. + +=item --wiki + +If TARGET is a URL, print Trac link for the diff. + +=item -x [--extensions] arg + +As described below in the help for "L<svn|svn> diff". + +=back + +Other options: + +=over 4 + +=item -g [--graphical] + +Use a graphical diff tool to display the differences. This option should not be +used in combination with --diff-cmd. + +=item --summarise + +Same as --summarize as described below. + +=back + +For other options, see output of "L<svn|svn> help diff". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d1/d1aa6a6b341af3e28fd47392c740e89a23a2e63f.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d1/d1aa6a6b341af3e28fd47392c740e89a23a2e63f.svn-base new file mode 100644 index 0000000..c7f118f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d1/d1aa6a6b341af3e28fd47392c740e89a23a2e63f.svn-base @@ -0,0 +1,146 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Entry::Location; +use base qw{Fcm::Keyword::Entry}; + +use Fcm::Keyword::Config; + +sub new { + my ($class, $args_ref) = @_; + if (!$args_ref) { + $args_ref = {}; + } + $args_ref = { + browser_rev_template => undef, + browser_url_template => undef, + implied_entry_list => [], + is_implied => 0, + location_component_pattern => undef, + revision_entries => Fcm::Keyword::Config::get_entries( + 'REVISION_ENTRIES', $args_ref, + ), + %{$args_ref}, + }, + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + # Returns a template for constructing the browser URL + 'browser_url_template', + # Returns a template for constructing the revision part in the browser URL + 'browser_rev_template', + # Returns a list of entries implied this entry + 'implied_entry_list', + # Returns the component pattern for a location matching this entry + 'location_component_pattern', + # Returns the entries for revision keywords + 'revision_entries', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + return $self->{$key}; + } +} + +################################################################################ +# Returns true if this is an implied entry +sub is_implied { + my ($self) = @_; + return $self->{is_implied}; +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Entry::Location + +=head1 SYNOPSIS + + use Fcm::Keyword::Entry::Location; + + $entry = Fcm::Keyword::Entry::Location->new({ + key => $key, value => $value, # ... + }); + + $key = $entry->get_key(); + $value = $entry->get_value(); + $revision_entries = $entry->get_revision_entries(); + +=head1 DESCRIPTION + +This is a sub-class of L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>. An object of +this class represents a FCM location keyword entry. + +=head1 METHODS + +See L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> for inherited methods. + +=over 4 + +=item new($args_ref) + +Constructor. + +=item get_browser_url_template() + +Returns the template string for constructing the browser URL. The string {1}, +{2}, {3}, etc in the template string will be substituted by the components +captured by the location component pattern and the revision template. See +C<get_url_component_pattern()> and C<get_browser_rev_template()>. + +=item get_browser_rev_template() + +Returns the template string for constructing the revision part of the browser +URL. The string {1} in the template string will be substituted by the revision. +See C<get_browser_url_template()>. + +=item get_implied_entry_list() + +Returns a list of entries implied by this entry. + +=item get_location_component_pattern() + +Returns a regular expression, when matched against the scheme-specific-part in +the actual URI of a location in the namespace of this keyword entry, will +capture a list of components, which can then be used to replace the numbered +fields in the browser URL template. See C<get_browser_url_template()>. + +=item get_revision_entries() + +Returns a L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object containing the +revision keyword entries of this location. + +=item is_implied() + +Returns true if this is an implied entry. + +=back + +=head1 TO DO + +Introduce a Fcm::Keyword::Config module to store entries constructor setting. + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Config|Fcm::Keyword::Config>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d924e56b60e5f8acfdca423d01c4ce4a212b1559.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d924e56b60e5f8acfdca423d01c4ce4a212b1559.svn-base new file mode 100644 index 0000000..acd2a12 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d924e56b60e5f8acfdca423d01c4ce4a212b1559.svn-base @@ -0,0 +1,22 @@ +=head1 NAME + +fcm add + +=head1 SYNOPSIS + + fcm add [options] [args] + +=head1 OPTIONS + +=over 4 + +=item -c [--check] + +Check for any files or directories reported by "L<svn|svn> status" as not under +version control and add them. + +=back + +For other options, see output of "L<svn|svn> help add". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d93484edec9b38180b3dc68cfca97d46bf31802e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d93484edec9b38180b3dc68cfca97d46bf31802e.svn-base new file mode 100644 index 0000000..db1dbc7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d93484edec9b38180b3dc68cfca97d46bf31802e.svn-base @@ -0,0 +1,42 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Exception; +use base qw{Fcm::Exception}; + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Exception + +=head1 SYNOPSIS + + use Carp qw{croak}; + use Fcm::CLI::Exception; + croak(Fcm::CLI::Exception->new({message => 'something is wrong'})); + +=head1 DESCRIPTION + +This class extends L<Fcm::Exception|Fcm::Exception>. This exception is thrown +on errors associated with the command line interface. + +=head1 METHODS + +See L<Fcm::Exception|Fcm::Exception> for a list of methods. + +=head1 SEE ALSO + +L<Fcm::Exception|Fcm::Exception> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d9b217b3cbe358ea91ae7c29cd4706fd8871178e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d9b217b3cbe358ea91ae7c29cd4706fd8871178e.svn-base new file mode 100644 index 0000000..8dedac5 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/d9/d9b217b3cbe358ea91ae7c29cd4706fd8871178e.svn-base @@ -0,0 +1,128 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Loader::Config::Location; + +use Fcm::Config; + +my %IMPLIED_NAMESPACE_SUFFIX = (tr => 'trunk', br => 'branches', tg => 'tags'); + +sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); +} + +################################################################################ +# Returns 'Fcm::Config' +sub get_source { + my ($self) = @_; + return 'Fcm::Config'; +} + +################################################################################ +# Loads location keywords from Fcm::Config to $entries +sub load_to { + my ($self, $entries) = @_; + my $config = $self->get_source()->instance(); + my $load_counter = 0; + for my $key (keys(%{$config->setting('URL')})) { + my $value = $config->setting('URL', $key); + my $location_component_pattern = $config->setting( + 'URL_BROWSER_MAPPING', $key, 'LOCATION_COMPONENT_PATTERN'); + my $browser_url_template = $config->setting( + 'URL_BROWSER_MAPPING', $key, 'BROWSER_URL_TEMPLATE'); + my $browser_rev_template = $config->setting( + 'URL_BROWSER_MAPPING', $key, 'BROWSER_REV_TEMPLATE'); + my $entry = $entries->add_entry( + $key, + $value, + { + location_component_pattern => $location_component_pattern, + browser_url_template => $browser_url_template, + browser_rev_template => $browser_rev_template, + }, + ); + $load_counter++; + + # Set up implied keywords + for my $suffix (keys(%IMPLIED_NAMESPACE_SUFFIX)) { + my $value_suf = $value . '/' . $IMPLIED_NAMESPACE_SUFFIX{$suffix}; + for my $join (q{_}, q{-}) { + my $implied_entry = $entries->add_entry( + uc($key . $join . $suffix), + $value_suf, + {is_implied => 1}, + ); + push(@{$entry->get_implied_entry_list()}, $implied_entry); + $load_counter++; + } + } + } + return ($config->is_initialising() ? 0 : defined($load_counter)); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Loader::Config::Location + +=head1 SYNOPSIS + + $loader = Fcm::Keyword::Loader::Config::Location->new(); + $loader->load_to($entries); + +=head1 DESCRIPTION + +This class implements the L<Fcm::Keyword::Loader|Fcm::Keyword::Loader> +interface. + +Loads location keywords from L<Fcm::Config|Fcm::Config> into a +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object containing +L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location> objects. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item get_source() + +Returns the string "L<Fcm::Config|Fcm::Config>". + +=item load_to($entries) + +Loads location keywords and implied keywords from L<Fcm::Config|Fcm::Config> to +$entries. It also loads settings for mapping location to browser URL. Returns +true on success. (However, if L<Fcm::Config|Fcm::Config> is initialising, +returns false to force a reload next time.) + +=back + +=head1 TO DO + +Need a more flexible system for implied keywords. + +=head1 SEE ALSO + +L<Fcm::Config|Fcm::Config>, +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader>, +L<Fcm::Keyword::Loader::Config::Revision|Fcm::Keyword::Loader::Config::Revision> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/dc/dc0e03486840056ece0f7e7b32c1af61d4f3f6c8.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/dc/dc0e03486840056ece0f7e7b32c1af61d4f3f6c8.svn-base new file mode 100644 index 0000000..ea7aba4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/dc/dc0e03486840056ece0f7e7b32c1af61d4f3f6c8.svn-base @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = "normal"; + my %OPTIONS = (option1 => 1, option2 => 2, option3 => 3); + my @ARGUMENTS = ('argument 1', 'argument 2'); + my $invoker = $class->new({ + command => 'command', + options => \%OPTIONS, + arguments => \@ARGUMENTS, + }); + isa_ok($invoker, $class, $prefix); + is($invoker->get_command(), 'command', "$prefix: command"); + is_deeply({$invoker->get_options()}, \%OPTIONS, "$prefix: options"); + is_deeply([$invoker->get_arguments()], \@ARGUMENTS, "$prefix: arguments"); + eval { + $invoker->invoke(); + }; + isa_ok($@, 'Fcm::CLI::Exception', "$prefix: invoke"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/dc/dc7b67c5871373adc7cbd60c47bb79971176385e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/dc/dc7b67c5871373adc7cbd60c47bb79971176385e.svn-base new file mode 100644 index 0000000..955091f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/dc/dc7b67c5871373adc7cbd60c47bb79971176385e.svn-base @@ -0,0 +1,266 @@ +# ------------------------------------------------------------------------------ +# FCM central configuration file +# ------------------------------------------------------------------------------ + +# ------------------------------------------------------------------------------ +# Standard repository locations +# ------------------------------------------------------------------------------ + +# 3dVOM repository +set::url::3dvom svn://fcm9/3dVOM_svn/3dVOM + +# AAPP repository +set::url::aapp svn://fcm7/AAPP_svn/AAPP + +# AMV repository +set::url::amv svn://fcm7/AMV_svn/AMV + +# ANCIL repository +set::url::ancil svn://fcm8/ANCIL_svn/ANCIL + +# ATSR repository +set::url::atsr svn://fcm7/ATSR_svn/ATSR + +# BLASIUS repository +set::url::blasius svn://fcm2/BLASIUS_svn/BLASIUS + +# CICE repository +set::url::cice svn://fcm3/CICE_svn/CICE + +# CMA repository +set::url::cma svn://fcm9/CMA_svn/CMA + +# CVC repository +set::url::cvc_admin svn://fcm6/CVC_svn/Admin +set::url::bufr svn://fcm6/CVC_svn/BUFR +set::url::bullseye svn://fcm6/CVC_svn/Bullseye +set::url::cat svn://fcm6/CVC_svn/CAT +set::url::deicing svn://fcm6/CVC_svn/Deicing +set::url::ea svn://fcm6/CVC_svn/EA +set::url::ensemble svn://fcm6/CVC_svn/Ensemble +set::url::gales svn://fcm6/CVC_svn/Gales +set::url::ifv svn://fcm6/CVC_svn/IFV +set::url::mogreps svn://fcm6/CVC_svn/MOGREPS +set::url::openroad svn://fcm6/CVC_svn/OpenRoad +set::url::powertable svn://fcm6/CVC_svn/PowerTable +set::url::qnh svn://fcm6/CVC_svn/QNH +set::url::tafs svn://fcm6/CVC_svn/TAFS +set::url::warnings svn://fcm6/CVC_svn/WARNINGS + +# DA repository +set::url::da svn://fcm5/DA_svn/DA + +# ENS repository +set::url::ens svn://fcm9/ENS_svn/ENS + +# ERSEM repository +set::url::ersem svn://fcm3/ERSEM_svn/ERSEM +set::url::ersem_pml svn://fcm3/ERSEM_svn/ERSEM_PML + +# FCM repository +set::url::fcm svn://fcm1/FCM_svn/FCM +set::url::fcm_admin svn://fcm1/FCM_svn/Admin + + +# FLUME repository +set::url::flume_metadata svn://fcm2/FLUME_svn/metadata +set::url::flume_framework svn://fcm2/FLUME_svn/framework +set::url::flume_models svn://fcm2/FLUME_svn/models +set::url::flume_jobs svn://fcm2/FLUME_svn/jobs + +# FORMOST repository +set::url::formost_local svn://fcm9/FORMOST_svn/FORMOST_LOCAL +set::url::formost_remote svn://fcm9/FORMOST_svn/FORMOST_REMOTE + +# GEN repository +set::url::gen svn://fcm1/GEN_svn/GEN + +# GS repository +set::url::gs svn://fcm9/GS_svn/GS + +# HadGOA repository +set::url::hadgoa svn://fcm9/HadGOA_svn/HadGOA + +# HadISD repository +set::url::hadisd_gen svn://fcm9/HadISD_svn/general +set::url::hadisd_homog svn://fcm9/HadISD_svn/homogenisation +set::url::hadisd_qc svn://fcm9/HadISD_svn/quality_control + +# IRIS repository +set::url::iris svn://fcm9/IRIS_svn/IRIS + +# LEM repository +set::url::lem svn://fcm2/LEM_svn/LEM + +# LINK repository +set::url::link svn://fcm1/LINK_svn/LINK + +# MASS_MIG repository +set::url::mass_mig svn://fcm9/MASS_MIG_svn/MASS_MIG + +# MOOSE repository +set::url::moose svn://fcm9/MOOSE_svn/MOOSE + +# MOSIG repository +set::url::mosig svn://fcm9/MOSIG_svn/MOSIG + +# MUMTI repository +set::url::mumti svn://fcm1/MUMTI_svn/Project + +# NEMO repository +set::url::nemosys svn://fcm3/NEMO_svn/NEMOSYS +set::url::nemovar svn://fcm3/NEMO_svn/NEMOVAR +set::url::nemo svn://fcm3/NEMO_svn/NEMO +set::url::ioipsl svn://fcm3/NEMO_svn/IOIPSL +set::url::ocnasm svn://fcm3/NEMO_svn/OCNASM +set::url::nemoukmo svn://fcm3/NEMO_svn/UKMO + +# NWPSAF repository + +set::url::meto_1dvar svn://fcm7/NWPSAF_svn/MetOffice_1DVar +set::url::ssmis_1dvar svn://fcm7/NWPSAF_svn/ssmis_1DVar +set::url::ssmis_pp svn://fcm7/NWPSAF_svn/ssmis_PP + +# NWPWEB repository +set::url::www_nwp svn://fcm1/NWPWEB_svn/www_nwp + +# obsmon repository +set::url::obsmon_dc svn://fcm4/obsmon_svn/DC +set::url::obsmon_rtm svn://fcm4/obsmon_svn/RTM + +# ODB repository +set::url::odb svn://fcm4/ODB_svn/ODB + +# OCN repository +set::url::polcoms svn://fcm3/OCN_svn/POLCOMS + +# OPFC repository +set::url::opfc svn://fcm9/OPFC_svn/OPFC + +# OPS repository +set::url::ops svn://fcm4/OPS_svn/OPS +set::url::ops_admin svn://fcm4/OPS_svn/Admin +set::url::ops_data svn://fcm4/OPS_svn/Data +set::url::ops_external svn://fcm4/OPS_svn/External + +# OSTIA repository +set::url::ostia svn://fcm3/OSTIA_svn/OSTIA + +# PF repository +set::url::pf svn://fcm5/PF_svn/PF + +# PostProc repository +set::url::pp svn://fcm9/PostProc_svn/PostProc +set::url::ppancil svn://fcm9/PostProc_svn/PostProcAncil +set::url::ppvssps svn://fcm9/PostProc_svn/VerificationSSPS + +# PRISM repository +set::url::oasis3 svn://fcm2/PRISM_svn/OASIS3 +set::url::oasis4 svn://fcm2/PRISM_svn/OASIS4 +set::url::prism_ukmo svn://fcm2/PRISM_svn/PRISM_UKMO + +# radarnet repository +set::url::radarnet4 svn://fcm9/radarnet_svn/radarnet4 + +# RADSAT repository +set::url::polar svn://fcm7/RADSAT_svn/POLAR +set::url::radsat svn://fcm7/RADSAT_svn/RADSAT + +# ROPP repository +set::url::ropp_doc svn://fcm7/ROPP_svn/ropp_doc +set::url::ropp_src svn://fcm7/ROPP_svn/ropp_src +set::url::ropp_test svn://fcm7/ROPP_svn/ropp_test +set::url::ropp_web svn://fcm7/ROPP_svn/ropp_web + +# RTTOV repository +set::url::rttov svn://fcm7/RTTOV_svn/RTTOV +set::url::rttov8 svn://fcm7/RTTOV_svn/RTTOV8 +set::url::rttov9 svn://fcm7/RTTOV_svn/RTTOV9 + +# SAUtils repository +set::url::autoscat_global svn://fcm7/SAUtils_svn/AUTOSCAT_Global +set::url::autoscat_nae svn://fcm7/SAUtils_svn/AUTOSCAT_NAE +set::url::climetop svn://fcm7/SAUtils_svn/CLIMETOP +set::url::dataflow svn://fcm7/SAUtils_svn/DataFlow +set::url::gpsiwv_mon svn://fcm7/SAUtils_svn/GPSIWV_Mon +set::url::gpswv_nrt svn://fcm7/SAUtils_svn/GPSWV_NRT +set::url::gpsro_mon svn://fcm7/SAUtils_svn/GPSRO_Mon +set::url::iasi_mon svn://fcm7/SAUtils_svn/IASI_Mon +set::url::metstrike svn://fcm7/SAUtils_svn/METSTRIKE +set::url::scatwind_mon svn://fcm7/SAUtils_svn/Scatwind_Mon + +# SBV repository +set::url::sbv svn://fcm6/SBV_svn/SBV +set::url::sbv_admin svn://fcm6/SBV_svn/Admin + +# SCS repository +set::url::scs svn://fcm1/SCS_svn/SCS +set::url::scs_admin svn://fcm1/SCS_svn/Admin +set::url::tik svn://fcm1/SCS_svn/TIK +set::url::tt svn://fcm1/SCS_svn/TT + +# SPS repository +set::url::sps svn://fcm7/SPS_svn/SPS +set::url::tigger svn://fcm7/SPS_svn/Tigger +set::url::sps_archive svn://fcm7/SPS_svn/Archive + +# SURF repository +set::url::surf svn://fcm8/SURF_svn/SURF + +# SWARV repository +set::url::swarv svn://fcm9/SWARV_svn/SWARV + +# test repository +set::url::test svn://fcm1/test_svn/OPS + +# tutorial repository +set::url::tutorial svn://fcm1/tutorial_svn/tutorial + +# THORPEX repository +set::url::thorpex svn://fcm9/ENS_svn/ENS + +# TRUI repository +set::url::trui svn://fcm1/TRUI_svn/TRUI + +# UM repository +set::url::um svn://fcm2/UM_svn/UM +set::url::um_admin svn://fcm2/UM_svn/Admin +set::url::gcom svn://fcm2/UM_svn/GCOM + +# UM tutorial repository +set::url::um_tutorial svn://fcm2/UM_TUTORIAL_svn/UM + +# utils repository +set::url::app_publications svn://fcm9/utils_svn/APP_publications +set::url::asyncios svn://fcm9/utils_svn/asyncIOS +set::url::avapps_coldsoak svn://fcm9/utils_svn/avapps_coldsoak +set::url::avapps_verCB svn://fcm9/utils_svn/avapps_verCB +set::url::crmtest svn://fcm9/utils_svn/cr_model_testing +set::url::cr_valnote svn://fcm9/utils_svn/cr_validation_note +set::url::fray_utils svn://fcm9/utils_svn/fray_utils +set::url::hpss_tests svn://fcm9/utils_svn/HPSS_tests +set::url::jules_benchmarking svn://fcm9/utils_svn/jules_benchmarking +set::url::jules_standalone svn://fcm9/utils_svn/jules_standalone +set::url::kid svn://fcm9/utils_svn/KiD +set::url::numerical_methods svn://fcm9/utils_svn/numerical_methods +set::url::wavefc svn://fcm9/utils_svn/wave_forecasting + +# VAR repository +set::url::var svn://fcm5/VAR_svn/VAR +set::url::var_admin svn://fcm5/VAR_svn/Admin +set::url::var_data svn://fcm5/VAR_svn/Data + +# VER repository +set::url::ver svn://fcm6/VER_svn/VER +set::url::ver_admin svn://fcm6/VER_svn/Admin +set::url::ver_archive svn://fcm6/VER_svn/Archive + +# VMM repository +set::url::vmm svn://fcm9/VMM_svn/VMM + +# WW3 repository +set::url::ww3 svn://fcm3/WW3_svn/WW3 +set::url::ww3_config svn://fcm3/WW3_svn/WW3CONFIG +set::url::ww3_utils svn://fcm3/WW3_svn/WW3UTILS + +# EOF diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/de/de0f7bd66402661d9f559f04d214ca2eec7bec7c.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/de/de0f7bd66402661d9f559f04d214ca2eec7bec7c.svn-base new file mode 100644 index 0000000..f4665eb --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/de/de0f7bd66402661d9f559f04d214ca2eec7bec7c.svn-base @@ -0,0 +1,1118 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Extract +# +# DESCRIPTION +# This is the top level class for the FCM extract system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Extract; +@ISA = qw(Fcm::ConfigSystem); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use File::Path; +use File::Spec; + +# FCM component modules +use Fcm::CfgFile; +use Fcm::CfgLine; +use Fcm::Config; +use Fcm::ConfigSystem; +use Fcm::Dest; +use Fcm::ExtractFile; +use Fcm::ExtractSrc; +use Fcm::Keyword; +use Fcm::ReposBranch; +use Fcm::SrcDirLayer; +use Fcm::Util; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'bdeclare', # list of build declarations + 'branches', # list of repository branches + 'conflict', # conflict mode + 'rdest' , # remote destination information +); + +# List of hash property methods for this class +my @hash_properties = ( + 'srcdirs' , # list of source directory extract info + 'files', # list of files processed key=pkgname, value=Fcm::ExtractFile +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Extract->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Extract class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::ConfigSystem->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + $self->{$_} = {} for (@hash_properties); + + bless $self, $class; + + # List of sub-methods for parse_cfg + push @{ $self->cfg_methods }, (qw/rdest bld conflict project/); + + # System type + $self->type ('ext'); + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'bdeclare' or $name eq 'branches') { + # Reference to an array + $self->{$name} = []; + + } elsif ($name eq 'rdest') { + # New extract destination local/remote + $self->{$name} = Fcm::Dest->new (DEST0 => $self->dest(), TYPE => 'ext'); + + } elsif ($name eq 'conflict') { + # Conflict mode, default to "merge" + $self->{$name} = 'merge'; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->check_lock_is_allowed ($lock); +# +# DESCRIPTION +# This method returns true if it is OK for $lock to exist in the destination. +# ------------------------------------------------------------------------------ + +sub check_lock_is_allowed { + my ($self, $lock) = @_; + + # Allow existence of build lock in inherited extract + return ($lock eq $self->dest->bldlock and @{ $self->inherited }); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_extract (); +# +# DESCRIPTION +# This method invokes the extract stage of the extract system. It returns +# true on success. +# ------------------------------------------------------------------------------ + +sub invoke_extract { + my $self = shift; + + my $rc = 1; + + my @methods = ( + 'expand_cfg', # expand URL, revision keywords, relative path, etc + 'create_dir_stack', # analyse the branches to create an extract sequence + 'extract_src', # use the sequence to extract source to destination + 'write_cfg', # generate final configuration file + 'write_cfg_bld', # generate build configuration file + ); + + for my $method (@methods) { + $rc = $self->$method if $rc; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_mirror (); +# +# DESCRIPTION +# This method invokes the mirror stage of the extract system. It returns +# true on success. +# ------------------------------------------------------------------------------ + +sub invoke_mirror { + my $self = shift; + return $self->rdest->mirror ([qw/bldcfg extcfg srcdir/]); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_system (); +# +# DESCRIPTION +# This method invokes the extract system. It returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_system { + my $self = shift; + + my $rc = 1; + + $rc = $self->invoke_stage ('Extract', 'invoke_extract'); + $rc = $self->invoke_stage ('Mirror', 'invoke_mirror') + if $rc and $self->rdest->rootdir; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_rdest(\@cfg_lines); +# +# DESCRIPTION +# This method parses the remote destination settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_rdest { + my ($self, $cfg_lines_ref) = @_; + + # RDEST declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg('RDEST')} @{$cfg_lines_ref}) { + my ($d, $method) = map {lc($_)} $line->slabel_fields(); + $method ||= 'rootdir'; + if ($self->rdest()->can($method)) { + $self->rdest()->$method(expand_tilde($line->value())); + $line->parsed(1); + } + } + + # MIRROR declaration, deprecated = RDEST::MIRROR_CMD + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg('MIRROR')} @{$cfg_lines_ref}) { + $self->rdest()->mirror_cmd($line->value()); + $line->parsed(1); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_bld (\@cfg_lines); +# +# DESCRIPTION +# This method parses the build configurations in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_bld { + my ($self, $cfg_lines) = @_; + + # BLD declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('BDECLARE')} @$cfg_lines) { + # Remove BLD from label + my @words = $line->slabel_fields; + + # Check that a declaration follows BLD + next if @words <= 1; + + push @{ $self->bdeclare }, Fcm::CfgLine->new ( + LABEL => join ($Fcm::Config::DELIMITER, @words), + PREFIX => $self->cfglabel ('BDECLARE'), + VALUE => $line->value, + ); + $line->parsed (1); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_conflict (\@cfg_lines); +# +# DESCRIPTION +# This method parses the conflict settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_conflict { + my ($self, $cfg_lines) = @_; + + # Deprecated: Override mode setting + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('OVERRIDE')} @$cfg_lines) { + next if ($line->slabel_fields) > 1; + $self->conflict ($line->bvalue ? 'override' : 'fail'); + $line->parsed (1); + $line->warning($line->slabel . ' is deprecated. Use ' . + $line->cfglabel('CONFLICT') . ' override|merge|fail.'); + } + + # Conflict mode setting + # ---------------------------------------------------------------------------- + my @conflict_modes = qw/fail merge override/; + my $conflict_modes_pattern = join ('|', @conflict_modes); + for my $line (grep {$_->slabel_starts_with_cfg ('CONFLICT')} @$cfg_lines) { + if ($line->value =~ /$conflict_modes_pattern/i) { + $self->conflict (lc ($line->value)); + $line->parsed (1); + + } elsif ($line->value =~ /^[012]$/) { + $self->conflict ($conflict_modes[$line->value]); + $line->parsed (1); + + } else { + $line->error ($line->value, ': invalid value'); + } + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_project (\@cfg_lines); +# +# DESCRIPTION +# This method parses the project settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_project { + my ($self, $cfg_lines) = @_; + + # Flag to indicate that a declared branch revision must match with its changed + # revision + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('REVMATCH')} @$cfg_lines) { + next if ($line->slabel_fields) > 1; + $self->setting ([qw/EXT_REVMATCH/], $line->bvalue); + $line->parsed (1); + } + + # Repository, revision and source directories + # ---------------------------------------------------------------------------- + for my $name (qw/repos revision dirs expdirs/) { + my @lines = grep { + $_->slabel_starts_with_cfg (uc ($name)) or + $name eq 'revision' and $_->slabel_starts_with_cfg ('VERSION'); + } @$cfg_lines; + for my $line (@lines) { + my @names = $line->slabel_fields; + shift @names; + + # Detemine package and tag + my $tag = pop @names; + my $pckroot = $names[0]; + my $pck = join ($Fcm::Config::DELIMITER, @names); + + # Check that $tag and $pckroot are defined + next unless $tag and $pckroot; + + # Check if branch already exists. + # If so, set $branch to point to existing branch + my $branch = undef; + for (@{ $self->branches }) { + next unless $_->package eq $pckroot and $_->tag eq $tag; + + $branch = $_; + last; + } + + # Otherwise, create a new branch + if (not $branch) { + $branch = Fcm::ReposBranch->new (PACKAGE => $pckroot, TAG => $tag,); + + push @{ $self->branches }, $branch; + } + + if ($name eq 'repos' or $name eq 'revision') { + # Branch location or revision + $branch->$name ($line->value); + + } else { # $name eq 'dirs' or $name eq 'expdirs' + # Source directory or expandable source directory + if ($pck eq $pckroot and $line->value !~ m#^/#) { + # Sub-package name not set and source directory quoted as a relative + # path, determine package name from path name + $pck = join ( + $Fcm::Config::DELIMITER, + ($pckroot, File::Spec->splitdir ($line->value)), + ); + } + + # A "/" is equivalent to the top (empty) package + my $value = ($line->value =~ m#^/+$#) ? '' : $line->value; + $branch->$name ($pck, $value); + } + + $line->parsed (1); + } + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_cfg (); +# +# DESCRIPTION +# This method expands the settings of the extract configuration. +# ------------------------------------------------------------------------------ + +sub expand_cfg { + my $self = shift; + + my $rc = 1; + for my $use (@{ $self->inherit }) { + $rc = $use->expand_cfg if $rc; + } + + return $rc unless $rc; + + # Establish a set of source directories from the "base repository" + my %base_branches = (); + + # Inherit "base" set of source directories from re-used extracts + for my $use (@{ $self->inherit }) { + my @branches = @{ $use->branches }; + + for my $branch (@branches) { + my $package = $branch->package; + $base_branches{$package} = $branch unless exists $base_branches{$package}; + } + } + + for my $branch (@{ $self->branches }) { + # Expand URL keywords if necessary + if ($branch->repos) { + my $repos = Fcm::Util::tidy_url(Fcm::Keyword::expand($branch->repos())); + $branch->repos ($repos) if $repos ne $branch->repos; + } + + # Check that repository type and revision are set + if ($branch->repos and &is_url ($branch->repos)) { + $branch->type ('svn') unless $branch->type; + $branch->revision ('head') unless $branch->revision; + + } else { + $branch->type ('user') unless $branch->type; + $branch->revision ('user') unless $branch->revision; + } + + $rc = $branch->expand_revision if $rc; # Get revision number from keywords + $rc = $branch->expand_path if $rc; # Expand relative path to full path + $rc = $branch->expand_all if $rc; # Search sub-directories + last unless $rc; + + my $package = $branch->package; + + if (exists $base_branches{$package}) { + # A base branch for this package exists + + # If current branch has no source directory, use the set provided by the + # base branch + my %dirs = %{ $branch->dirs }; + $branch->add_base_dirs ($base_branches{$package}) unless keys %dirs; + + } else { + # This package does not yet have a base branch, set this branch as base + $base_branches{$package} = $branch; + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->create_dir_stack (); +# +# DESCRIPTION +# This method creates a hash of source directories to be processed. If the +# flag INHERITED is set to true, the source directories are assumed processed +# and extracted. +# ------------------------------------------------------------------------------ + +sub create_dir_stack { + my $self = shift; + my %args = @_; + + # Inherit from USE ext cfg + for my $use (@{ $self->inherit }) { + $use->create_dir_stack () or return 0; + my %use_srcdirs = %{ $use->srcdirs }; + + while (my ($key, $value) = each %use_srcdirs) { + $self->srcdirs ($key, $value); + + # Re-set destination to current destination + my @path = split (/$Fcm::Config::DELIMITER/, $key); + $self->srcdirs ($key)->{DEST} = File::Spec->catfile ( + $self->dest->srcdir, @path, + ); + } + } + + # Build stack from current ext cfg + for my $branch (@{ $self->branches }) { + my %branch_dirs = %{ $branch->dirs }; + + for my $dir (keys %branch_dirs) { + # Check whether source directory is already in the list + if (not $self->srcdirs ($dir)) { # if not, create it + $self->srcdirs ($dir, { + DEST => File::Spec->catfile ( + $self->dest->srcdir, split (/$Fcm::Config::DELIMITER/, $dir) + ), + STACK => [], + FILES => {}, + }); + } + + my $stack = $self->srcdirs ($dir)->{STACK}; # copy reference + + # Create a new layer in the input stack + my $layer = Fcm::SrcDirLayer->new ( + NAME => $dir, + PACKAGE => $branch->package, + TAG => $branch->tag, + LOCATION => $branch->dirs ($dir), + REPOSROOT => $branch->repos, + REVISION => $branch->revision, + TYPE => $branch->type, + EXTRACTED => @{ $self->inherited } + ? $self->srcdirs ($dir)->{DEST} : undef, + ); + + # Check whether layer is already in the stack + my $exist = grep { + $_->location eq $layer->location and $_->revision eq $layer->revision; + } @{ $stack }; + + if (not $exist) { + # If not already exist, put layer into stack + + # Note: user stack always comes last + if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) { + my $lastlayer = pop @{ $stack }; + push @{ $stack }, $layer; + $layer = $lastlayer; + } + + push @{ $stack }, $layer; + + } elsif ($layer->user) { + + # User layer already exists, overwrite it + $stack->[-1] = $layer; + + } + } + } + + # Use the cache to sort the source directory layer hash + return $self->compare_setting (METHOD_LIST => ['sort_dir_stack']); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, \@new_lines) = $self->sort_dir_stack ($old_lines); +# +# DESCRIPTION +# This method sorts thesource directories hash to be processed. +# ------------------------------------------------------------------------------ + +sub sort_dir_stack { + my ($self, $old_lines) = @_; + + my $rc = 0; + + my %old = (); + if ($old_lines) { + for my $line (@$old_lines) { + $old{$line->label} = $line->value; + } + } + + my %new; + + # Compare each layer to base layer, discard unnecessary layers + DIR: for my $srcdir (keys %{ $self->srcdirs }) { + my @stack = (); + + while (my $layer = shift @{ $self->srcdirs ($srcdir)->{STACK} }) { + if ($layer->user) { + # Local file system branch, check that the declared location exists + if (-d $layer->location) { + # Local file system branch always takes precedence + push @stack, $layer; + + } else { + w_report 'ERROR: ', $layer->location, ': declared source directory ', + 'does not exists '; + $rc = undef; + last DIR; + } + + } else { + my $key = join ($Fcm::Config::DELIMITER, ( + $srcdir, $layer->location, $layer->revision + )); + + unless ($layer->extracted and $layer->commit) { + # See if commit revision information is cached + if (keys %old and exists $old{$key}) { + $layer->commit ($old{$key}); + + } else { + $layer->get_commit; + $rc = 1; + } + + # Check source directory for commit revision, if necessary + if (not $layer->commit) { + w_report 'Error: cannot determine the last changed revision of ', + $layer->location; + $rc = undef; + last DIR; + } + + # Set cache directory for layer + my $tag_ver = $layer->tag . '__' . $layer->commit; + $layer->cachedir (File::Spec->catfile ( + $self->dest->cachedir, + split (/$Fcm::Config::DELIMITER/, $srcdir), + $tag_ver, + )); + } + + # New line in cache config file + $new{$key} = $layer->commit; + + # Push this layer in the stack: + # 1. it has a different revision compared to the top layer + # 2. it is the top layer (base line code) + if (@stack > 0) { + push @stack, $layer if $layer->commit != $stack[0]->commit; + + } else { + push @stack, $layer; + } + + } + } + + $self->srcdirs ($srcdir)->{STACK} = \@stack; + } + + # Write "commit cache" file + my @new_lines; + if (defined ($rc)) { + for my $key (sort keys %new) { + push @new_lines, Fcm::CfgLine->new (label => $key, value => $new{$key}); + } + } + + return ($rc, \@new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->extract_src (); +# +# DESCRIPTION +# This internal method performs the extract of the source directories and +# files if necessary. +# ------------------------------------------------------------------------------ + +sub extract_src { + my $self = shift; + my $rc = 1; + + # Ensure destinations exist and are directories + for my $srcdir (values %{ $self->srcdirs }) { + last if not $rc; + if (-f $srcdir->{DEST}) { + w_report $srcdir->{DEST}, + ': destination exists and is not a directory, abort.'; + $rc = 0; + } + } + + # Retrieve previous/record current extract configuration for each file. + $rc = $self->compare_setting ( + CACHEBASE => $self->setting ('CACHE_FILE_SRC'), + METHOD_LIST => ['compare_setting_srcfiles'], + ) if $rc; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, \@new_lines) = $self->compare_setting_srcfiles ($old_lines); +# +# DESCRIPTION +# For each file to be extracted, this method creates an instance of an +# Fcm::ExtractFile object. It then compares its file's sources to determine +# if they have changed. If so, it will allow the Fcm::ExtractFile to +# "re-extract" the file to the destination. Otherwise, it will set +# Fcm::ExtractFile->dest_status to a null string to denote an "unchanged" +# dest_status. +# +# SEE ALSO +# Fcm::ConfigSystem->compare_setting. +# ------------------------------------------------------------------------------ + +sub compare_setting_srcfiles { + my ($self, $old_lines) = @_; + my $rc = 1; + + # Retrieve previous extract configuration for each file + # ---------------------------------------------------------------------------- + my %old = (); + if ($old_lines) { + for my $line (@$old_lines) { + $old{$line->label} = $line->value; + } + } + + # Build up a sequence using a Fcm::ExtractFile object for each file + # ---------------------------------------------------------------------------- + for my $srcdir (values %{ $self->srcdirs }) { + my %pkgnames0; # (to be) list of package names in the base layer + for my $i (0 .. @{ $srcdir->{STACK} } - 1) { + my $layer = $srcdir->{STACK}->[$i]; + # Update the cache for each layer of the stack if necessary + $layer->update_cache unless $layer->extracted or -d $layer->localdir; + + # Get list of files in the cache or local directory + my %pkgnames; + for my $file (($layer->get_files)) { + my $pkgname = join ( + '/', split (/$Fcm::Config::DELIMITER/, $layer->name), $file + ); + $pkgnames0{$pkgname} = 1 if $i == 0; # store package name in base layer + $pkgnames{$pkgname} = 1; # store package name in the current layer + if (not $self->files ($pkgname)) { + $self->files ($pkgname, Fcm::ExtractFile->new ( + conflict => $self->conflict, + dest => $self->dest->srcpath, + pkgname => $pkgname, + )); + + # Base is empty + $self->files ($pkgname)->src->[0] = Fcm::ExtractSrc->new ( + id => $layer->tag, + pkgname => $pkgname, + ) if $i > 0; + } + my $cache = File::Spec->catfile ($layer->localdir, $file); + push @{ $self->files ($pkgname)->src }, Fcm::ExtractSrc->new ( + cache => $cache, + id => $layer->tag, + pkgname => $pkgname, + rev => ($layer->user ? (stat ($cache))[9] : $layer->commit), + uri => join ('/', $layer->location, $file), + ); + } + + # List of removed files in this layer (relative to base layer) + if ($i > 0) { + for my $pkgname (keys %pkgnames0) { + push @{ $self->files ($pkgname)->src }, Fcm::ExtractSrc->new ( + id => $layer->tag, + pkgname => $pkgname, + ) if not exists $pkgnames{$pkgname} + } + } + } + } + + # Compare with old settings + # ---------------------------------------------------------------------------- + my %new = (); + for my $key (sort keys %{ $self->files }) { + # Set up value for cache + my @sources = (); + for my $src (@{ $self->files ($key)->src }) { + push @sources, (defined ($src->uri) ? ($src->uri . '@' . $src->rev) : ''); + } + + my $value = join ($Fcm::Config::DELIMITER, @sources); + + # Set Fcm::ExtractFile->dest_status to "unchanged" if value is unchanged + $self->files ($key)->dest_status ('') + if exists $old{$key} and $old{$key} eq $value; + + # Write current settings + $new{$key} = $value; + } + + # Delete those that exist in previous extract but not in current + # ---------------------------------------------------------------------------- + for my $key (sort keys %old) { + next if exists $new{$key}; + $self->files ($key, Fcm::ExtractFile->new ( + dest => $self->dest->srcpath, + pkgname => $key, + )); + } + + # Extract each file, if necessary + # ---------------------------------------------------------------------------- + for my $key (sort keys %{ $self->files }) { + $rc = $self->files ($key)->run if defined ($rc); + last if not defined ($rc); + } + + # Report status + # ---------------------------------------------------------------------------- + if (defined ($rc) and $self->verbose) { + my %src_status_count = (); + my %dest_status_count = (); + for my $key (sort keys %{ $self->files }) { + # Report changes in destination in verbose 1 or above + my $dest_status = $self->files ($key)->dest_status; + my $src_status = $self->files ($key)->src_status; + next unless $self->verbose and $dest_status; + + if ($dest_status and $dest_status ne '?') { + if (exists $dest_status_count{$dest_status}) { + $dest_status_count{$dest_status}++; + + } else { + $dest_status_count{$dest_status} = 1; + } + } + + if ($src_status and $src_status ne '?') { + if (exists $src_status_count{$src_status}) { + $src_status_count{$src_status}++; + + } else { + $src_status_count{$src_status} = 1; + } + } + + # Destination status in column 1, source status in column 2 + if ($self->verbose > 1) { + my @srcs = @{$self->files ($key)->src_actual}; + print ($dest_status ? $dest_status : ' '); + print ($src_status ? $src_status : ' '); + print ' ' x 5, $key; + print ' (', join (', ', map {$_->id} @srcs), ')' if @srcs; + print "\n"; + } + } + + # Report number of files in each dest_status category + if (%dest_status_count) { + print 'Column 1: ' if $self->verbose > 1; + print 'Destination status summary:', "\n"; + for my $key (sort keys %Fcm::ExtractFile::DEST_STATUS_CODE) { + next unless $key; + next if not exists ($dest_status_count{$key}); + print ' No of files '; + print '[', $key, '] ' if $self->verbose > 1; + print $Fcm::ExtractFile::DEST_STATUS_CODE{$key}, ': ', + $dest_status_count{$key}, "\n"; + } + } + + # Report number of files in each dest_status category + if (%src_status_count) { + print 'Column 2: ' if $self->verbose > 1; + print 'Source status summary:', "\n"; + for my $key (sort keys %Fcm::ExtractFile::SRC_STATUS_CODE) { + next unless $key; + next if not exists ($src_status_count{$key}); + print ' No of files '; + print '[', $key, '] ' if $self->verbose > 1; + print $Fcm::ExtractFile::SRC_STATUS_CODE{$key}, ': ', + $src_status_count{$key}, "\n"; + } + } + } + + # Record configuration of current extract for each file + # ---------------------------------------------------------------------------- + my @new_lines; + if (defined ($rc)) { + for my $key (sort keys %new) { + push @new_lines, Fcm::CfgLine->new (label => $key, value => $new{$key}); + } + } + + return ($rc, \@new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @array = $self->sort_bdeclare (); +# +# DESCRIPTION +# This method returns sorted build declarations, filtering out repeated +# entries, where possible. +# ------------------------------------------------------------------------------ + +sub sort_bdeclare { + my $self = shift; + + # Get list of build configuration labels that can be declared multiple times + my %cfg_keyword = map { + ($self->cfglabel ($_), 1) + } split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD')); + + my @bdeclares = (); + for my $d (reverse @{ $self->bdeclare }) { + # Reconstruct array from bottom up + # * always add declarations that can be declared multiple times + # * otherwise add only if it is declared below + unshift @bdeclares, $d + if exists $cfg_keyword{uc (($d->slabel_fields)[0])} or + not grep {$_->slabel eq $d->slabel} @bdeclares; + } + + return (sort {$a->slabel cmp $b->slabel} @bdeclares); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines (); +# +# DESCRIPTION +# See description of Fcm::ConfigSystem->to_cfglines for further information. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self) = @_; + + return ( + Fcm::ConfigSystem::to_cfglines($self), + + $self->rdest->to_cfglines (), + Fcm::CfgLine->new (), + + @{ $self->bdeclare } ? ( + Fcm::CfgLine::comment_block ('Build declarations'), + map { + Fcm::CfgLine->new (label => $_->label, value => $_->value) + } ($self->sort_bdeclare), + Fcm::CfgLine->new (), + ) : (), + + Fcm::CfgLine::comment_block ('Project and branches'), + (map {($_->to_cfglines ())} @{ $self->branches }), + + ($self->conflict ne 'merge') ? ( + Fcm::CfgLine->new ( + label => $self->cfglabel ('CONFLICT'), value => $self->conflict, + ), + Fcm::CfgLine->new (), + ) : (), + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines_bld (); +# +# DESCRIPTION +# Returns a list of configuration lines of the current extract suitable for +# feeding into the build system. +# ------------------------------------------------------------------------------ + +sub to_cfglines_bld { + my ($self) = @_; + + my $dest = $self->rdest->rootdir ? 'rdest' : 'dest'; + my $root = File::Spec->catfile ('$HERE', '..'); + + my @inherits; + my @no_inherits; + if (@{ $self->inherit }) { + # List of inherited builds + for (@{ $self->inherit }) { + push @inherits, Fcm::CfgLine->new ( + label => $self->cfglabel ('USE'), value => $_->$dest->rootdir + ); + } + + # List of files that should not be inherited + for my $key (sort keys %{ $self->files }) { + next unless $self->files ($key)->dest_status eq 'd'; + my $label = join ('::', ( + $self->cfglabel ('INHERIT'), + $self->cfglabel ('FILE'), + split (m#/#, $self->files ($key)->pkgname), + )); + push @no_inherits, Fcm::CfgLine->new (label => $label, value => 'false'); + } + } + + return ( + Fcm::CfgLine::comment_block ('File header'), + (map + {my ($lbl, $val) = @{$_}; Fcm::CfgLine->new(label => $lbl, value => $val)} + ( + [$self->cfglabel('CFGFILE') . $Fcm::Config::DELIMITER . 'TYPE' , 'bld'], + [$self->cfglabel('CFGFILE') . $Fcm::Config::DELIMITER . 'VERSION', '1.0'], + [], + ) + ), + + @{ $self->inherit } ? ( + @inherits, + @no_inherits, + Fcm::CfgLine->new (), + ) : (), + + Fcm::CfgLine::comment_block ('Destination'), + Fcm::CfgLine->new (label => $self->cfglabel ('DEST'), value => $root), + Fcm::CfgLine->new (), + + @{ $self->bdeclare } ? ( + Fcm::CfgLine::comment_block ('Build declarations'), + map { + Fcm::CfgLine->new (label => $_->slabel, value => $_->value) + } ($self->sort_bdeclare), + Fcm::CfgLine->new (), + ) : (), + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->write_cfg (); +# +# DESCRIPTION +# This method writes the configuration file at the end of the run. It calls +# $self->write_cfg_system ($cfg) to write any system specific settings. +# ------------------------------------------------------------------------------ + +sub write_cfg { + my $self = shift; + + my $cfg = Fcm::CfgFile->new (TYPE => $self->type); + $cfg->lines ([$self->to_cfglines()]); + $cfg->print_cfg ($self->dest->extcfg); + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->write_cfg_bld (); +# +# DESCRIPTION +# This internal method writes the build configuration file. +# ------------------------------------------------------------------------------ + +sub write_cfg_bld { + my $self = shift; + + my $cfg = Fcm::CfgFile->new (TYPE => 'bld'); + $cfg->lines ([$self->to_cfglines_bld()]); + $cfg->print_cfg ($self->dest->bldcfg); + + return 1; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/e0/e098e4b3f4a821666f5f4d4d9f5e06260176e93e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/e0/e098e4b3f4a821666f5f4d4d9f5e06260176e93e.svn-base new file mode 100644 index 0000000..cb069dd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/e0/e098e4b3f4a821666f5f4d4d9f5e06260176e93e.svn-base @@ -0,0 +1,323 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Carp qw{croak}; +use Fcm::Keyword::Config; +use Test::More (tests => 227); + +BEGIN: { + use_ok('Fcm::Keyword'); +} + +if (!caller()) { + main(@ARGV); +} + +sub main { + local @ARGV = @_; + local %Fcm::Keyword::Config::CONFIG_OF = ( + LOCATION_ENTRIES => {entry_class => 'Fcm::Keyword::Entry::Location'}, + REVISION_ENTRIES => {entry_class => 'Fcm::Keyword::Entry'}, + ); + test_get_prefix_of_location_keyword(); + test_get_entries(); + test_expand(); + test_unexpand(); + test_get_browser_url(); +} + +################################################################################ +# Tests get_prefix_of_location_keyword(). +sub test_get_prefix_of_location_keyword { + is(Fcm::Keyword::get_prefix_of_location_keyword(), 'fcm'); + is(Fcm::Keyword::get_prefix_of_location_keyword(1), 'fcm:'); +} + +################################################################################ +# Tests get_entries(). +sub test_get_entries { + my $entries = Fcm::Keyword::get_entries(); + isa_ok($entries, 'Fcm::Keyword::Entries'); + for (1 .. 10) { + is(Fcm::Keyword::get_entries(), $entries, "get_entries: is singleton"); + } + isnt(Fcm::Keyword::get_entries(1), $entries, "get_entries: can reset"); +} + +################################################################################ +# Tests expand(). +sub test_expand { + my $T = 'expand'; + + # Add some keywords for testing + _add_keyword_entries([ + # ['name' , 'value' , {'rev1' => rev, ...}], + ['FOO' , 'test://foo/foo' , {'V1.0' => 256, 'V1-1' => 4790}], + ['FOO-TR', 'test://foo/foo/trunk', {}], + ]); + + _do_keyword_tests($T, \&Fcm::Keyword::expand, [ + # Tests to ensure that valid targets are expanded + # [['input' ], ['expected' ]], + [['fcm:FOO' ], ['test://foo/foo' ]], + [['fcm:FOO' , 'V1.0'], ['test://foo/foo' , '256' ]], + [['fcm:Foo' ], ['test://foo/foo' ]], + [['fcm:foo' ], ['test://foo/foo' ]], + [['fcm:foo' , 'v1.0'], ['test://foo/foo' , '256' ]], + [['fcm:foo' , 'head'], ['test://foo/foo' , 'head']], + [['fcm:foo/' ], ['test://foo/foo/' ]], + [['fcm:foo/' , '1234'], ['test://foo/foo/' , '1234']], + [['fcm:foo/' , 'v1.0'], ['test://foo/foo/' , '256' ]], + [['fcm:foo/' , 'v1-1'], ['test://foo/foo/' , '4790']], + [['fcm:foo/bar' ], ['test://foo/foo/bar' ]], + [['fcm:foo/bar' , 'PREV'], ['test://foo/foo/bar' , 'PREV']], + [['fcm:foo/bar' , 'base'], ['test://foo/foo/bar' , 'base']], + [['fcm:foo/bar' , 'v1-1'], ['test://foo/foo/bar' , '4790']], + [['fcm:foo/bar/', '7777'], ['test://foo/foo/bar/' , '7777']], + [['fcm:foo/bar/', '{11}'], ['test://foo/foo/bar/' , '{11}']], + [['fcm:foo/bar/', 'v1.0'], ['test://foo/foo/bar/' , '256' ]], + [['fcm:foo-tr' ], ['test://foo/foo/trunk' ]], + [['fcm:foo-tr' , 'head'], ['test://foo/foo/trunk' , 'head']], + [['fcm:foo-tr' , 'v1.0'], ['test://foo/foo/trunk' , '256' ]], + [['fcm:foo-tr/' ], ['test://foo/foo/trunk/' ]], + [['fcm:foo-tr/' , '1234'], ['test://foo/foo/trunk/', '1234']], + [['fcm:foo-tr/' , 'v1-1'], ['test://foo/foo/trunk/', '4790']], + # Tests to ensure that non-keyword targets are not expanded + # [['input' ]], # 'expected' same as 'input' + [['no-change' ]], + [['foo/bar' ]], + [['/foo/bar' ]], + [['/foo/bar' , 'head' ]], + [['/foo/bar/' ]], + [['/foo/bar/' , 'not-a-key']], + [['svn://foo/bar' ]], + [['svn://foo/bar', '1234' ]], + [['file://foo/bar' ]], + [['http://foo/bar' ]], + ]); + + # Tests for unexpected keywords + for my $key (qw{foo bar baz}) { + eval { + Fcm::Keyword::expand("fcm:foo\@$key"); + }; + isa_ok($@, 'Fcm::Keyword::Exception', "$T: $key: invalid revision"); + } + + # Tests for "undef", all expecting exceptions + for my $target_ref ([undef], [undef, undef], [undef, 'foo']) { + eval { + Fcm::Keyword::expand(@{$target_ref}); + }; + isa_ok($@, 'Fcm::Exception', "$T: undef"); + } +} + +################################################################################ +# Tests unexpand(). +sub test_unexpand { + my $T = 'unexpand'; + + # Add some keywords for testing + _add_keyword_entries([ + # ['name' , 'value' , {'rev1' => rev, ...}], + ['FOO' , 'test://foo/foo' , {'V1.0' => 256, 'V1-1' => 4790}], + ['FOO_TR', 'test://foo/foo/trunk', {}], + ['FOO-TR', 'test://foo/foo/trunk', {}], + ]); + + _do_keyword_tests($T, \&Fcm::Keyword::unexpand, [ + # Tests to ensure that valid targets are expanded + # [['input' ], ['expected' ]], + [['test://foo/foo' ], ['fcm:FOO' ]], + [['test://foo/foo' , '256' ], ['fcm:FOO' , 'V1.0']], + [['test://foo/foo' , 'head'], ['fcm:FOO' , 'head']], + [['test://foo/foo/' ], ['fcm:FOO/' ]], + [['test://foo/foo/' , '1234'], ['fcm:FOO/' , '1234']], + [['test://foo/foo/' , '256' ], ['fcm:FOO/' , 'V1.0']], + [['test://foo/foo/' , '4790'], ['fcm:FOO/' , 'V1-1']], + [['test://foo/foo/bar' ], ['fcm:FOO/bar' ]], + [['test://foo/foo/bar' , 'PREV'], ['fcm:FOO/bar' , 'PREV']], + [['test://foo/foo/bar' , 'base'], ['fcm:FOO/bar' , 'base']], + [['test://foo/foo/bar' , '4790'], ['fcm:FOO/bar' , 'V1-1']], + [['test://foo/foo/bar/' , '7777'], ['fcm:FOO/bar/', '7777']], + [['test://foo/foo/bar/' , '{11}'], ['fcm:FOO/bar/', '{11}']], + [['test://foo/foo/bar/' , '256' ], ['fcm:FOO/bar/', 'V1.0']], + [['test://foo/foo/trunk' ], ['fcm:FOO-TR' ]], + [['test://foo/foo/trunk' , 'head'], ['fcm:FOO-TR' , 'head']], + [['test://foo/foo/trunk' , '256' ], ['fcm:FOO-TR' , 'V1.0']], + [['test://foo/foo/trunk/' ], ['fcm:FOO-TR/' ]], + [['test://foo/foo/trunk/', '1234'], ['fcm:FOO-TR/' , '1234']], + [['test://foo/foo/trunk/', '4790'], ['fcm:FOO-TR/' , 'V1-1']], + # Tests to ensure that non-keyword targets are not expanded + # [['input' ]], # 'expected' same as 'input' + [['no-change' ]], + [['foo/bar' ]], + [['/foo/bar' ]], + [['/foo/bar' , 'head' ]], + [['/foo/bar/' ]], + [['/foo/bar/' , 'not-a-key']], + [['svn://foo/bar' ]], + [['svn://foo/bar', '1234' ]], + [['file://foo/bar' ]], + [['http://foo/bar' ]], + ]); + + # Tests for "undef", all expecting exceptions + for my $target_ref ([undef], [undef, undef], [undef, 'foo']) { + eval { + Fcm::Keyword::unexpand(@{$target_ref}); + }; + isa_ok($@, 'Fcm::Exception', "$T: undef"); + } +} + +################################################################################ +# Tests get_browser_url(). +sub test_get_browser_url { + my $T = 'get_browser_url'; + + # Add some keywords for testing + _add_keyword_entries([ + # ['name' , 'value' , {'rev1' => rev, ...}], + ['FOO' , 'test://foo/foo_svn/foo' , {'V1' => 256, 'W2' => 479}], + ['FOO-TR', 'test://foo/foo_svn/foo/trunk'], + ['FOO_TR', 'test://foo/foo_svn/foo/trunk'], + ]); + + my ($INPUT, $EXPECTED) = (0, 1); + my ($LOC, $REV) = (0, 1); + for my $test_ref ( + # Tests to ensure that valid targets are expanded + # [['input' ], 'expected' ], + [['test://foo/foo_svn/foo' ], 'http://foo/projects/foo/intertrac/source:foo' ], + [['test://foo/foo_svn/foo' , '256' ], 'http://foo/projects/foo/intertrac/source:foo@256' ], + [['test://foo/foo_svn/foo' , 'head'], 'http://foo/projects/foo/intertrac/source:foo@head' ], + [['test://foo/foo_svn/foo/' ], 'http://foo/projects/foo/intertrac/source:foo/' ], + [['test://foo/foo_svn/foo/' , '1234'], 'http://foo/projects/foo/intertrac/source:foo/@1234' ], + [['test://foo/foo_svn/foo/' , '256' ], 'http://foo/projects/foo/intertrac/source:foo/@256' ], + [['test://foo/foo_svn/foo/' , '479' ], 'http://foo/projects/foo/intertrac/source:foo/@479' ], + [['test://foo/foo_svn/foo/bar' ], 'http://foo/projects/foo/intertrac/source:foo/bar' ], + [['test://foo/foo_svn/foo/bar' , '479' ], 'http://foo/projects/foo/intertrac/source:foo/bar@479' ], + [['test://foo/foo_svn/foo/bar/' , '7777'], 'http://foo/projects/foo/intertrac/source:foo/bar/@7777' ], + [['test://foo/foo_svn/foo/bar/' , '{11}'], 'http://foo/projects/foo/intertrac/source:foo/bar/@{11}' ], + [['test://foo/foo_svn/foo/bar/' , '256' ], 'http://foo/projects/foo/intertrac/source:foo/bar/@256' ], + [['test://foo/foo_svn/foo/trunk' ], 'http://foo/projects/foo/intertrac/source:foo/trunk' ], + [['test://foo/foo_svn/foo/trunk' , 'head'], 'http://foo/projects/foo/intertrac/source:foo/trunk@head' ], + [['test://foo/foo_svn/foo/trunk' , '256' ], 'http://foo/projects/foo/intertrac/source:foo/trunk@256' ], + [['test://foo/foo_svn/foo/trunk/' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/' ], + [['test://foo/foo_svn/foo/trunk/', '1234'], 'http://foo/projects/foo/intertrac/source:foo/trunk/@1234'], + [['test://foo/foo_svn/foo/trunk/', '479' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/@479' ], + [['fcm:FOO' ], 'http://foo/projects/foo/intertrac/source:foo' ], + [['fcm:FOO' , 'V1' ], 'http://foo/projects/foo/intertrac/source:foo@256' ], + [['fcm:FOO' , 'head'], 'http://foo/projects/foo/intertrac/source:foo@head' ], + [['fcm:FOO/' ], 'http://foo/projects/foo/intertrac/source:foo/' ], + [['fcm:FOO/' , '1234'], 'http://foo/projects/foo/intertrac/source:foo/@1234' ], + [['fcm:FOO/' , 'V1' ], 'http://foo/projects/foo/intertrac/source:foo/@256' ], + [['fcm:FOO/' , 'W2' ], 'http://foo/projects/foo/intertrac/source:foo/@479' ], + [['fcm:FOO/bar' ], 'http://foo/projects/foo/intertrac/source:foo/bar' ], + [['fcm:FOO/bar' , 'W2' ], 'http://foo/projects/foo/intertrac/source:foo/bar@479' ], + [['fcm:FOO/bar/' , '7777'], 'http://foo/projects/foo/intertrac/source:foo/bar/@7777' ], + [['fcm:FOO/bar/' , '{11}'], 'http://foo/projects/foo/intertrac/source:foo/bar/@{11}' ], + [['fcm:FOO/bar/' , 'v1' ], 'http://foo/projects/foo/intertrac/source:foo/bar/@256' ], + [['fcm:FOO-TR' ], 'http://foo/projects/foo/intertrac/source:foo/trunk' ], + [['fcm:FOO-TR' , 'head'], 'http://foo/projects/foo/intertrac/source:foo/trunk@head' ], + [['fcm:FOO-TR' , 'V1' ], 'http://foo/projects/foo/intertrac/source:foo/trunk@256' ], + [['fcm:FOO-TR/' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/' ], + [['fcm:FOO-TR/' , '1234'], 'http://foo/projects/foo/intertrac/source:foo/trunk/@1234'], + [['fcm:FOO-TR/' , 'w2' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/@479' ], + ) { + my $input = $test_ref->[$INPUT][$LOC]; + if (exists($test_ref->[$INPUT][$REV])) { + $input .= '@' . $test_ref->[$INPUT][$REV]; + } + for ( + {name => "$T: scalar input: $input", input => [$input]}, + {name => "$T: list input: $input" , input => $test_ref->[$INPUT]}, + ) { + my $output; + eval { + $output = Fcm::Keyword::get_browser_url(@{$_->{input}}); + is($output, $test_ref->[$EXPECTED], $_->{name}); + }; + if ($@) { + fail("$_->{name}: $@"); + } + } + } + + # Tests correct behaviour for "undef" + for my $bad_url (undef, '') { + eval { + Fcm::Keyword::get_browser_url($bad_url); + }; + isa_ok($@, 'Fcm::Exception', sprintf( + "$T: %s", (defined($bad_url) ? $bad_url : 'undef'), + )); + } + + # Tests correct behaviour for invalid inputs + for my $bad_url ('foo', 'svn://no/such/url', 'fcm:no_such_project/trunk') { + eval { + Fcm::Keyword::get_browser_url($bad_url); + }; + isa_ok($@, 'Fcm::Keyword::Exception', "$T: $bad_url: invalid keyword"); + } +} + +################################################################################ +# Adds keyword entries. +sub _add_keyword_entries { + my ($items_ref) = @_; + my ($NAME, $LOC, $REV) = (0 .. 2); + my $entries = Fcm::Keyword::get_entries(1); # reset + for my $item_ref (@{$items_ref}) { + my $entry = $entries->add_entry($item_ref->[$NAME], $item_ref->[$LOC]); + while (my ($key, $value) = each(%{$item_ref->[$REV]})) { + $entry->get_revision_entries()->add_entry($key, $value); + } + } +} + +################################################################################ +# Performs keyword testings. +sub _do_keyword_tests { + my ($T, $action_ref, $tests_ref) = @_; + my ($INPUT, $EXPECTED) = (0, 1); + my ($LOC, $REV) = (0, 1); + for my $test_ref (@{$tests_ref}) { + if (!defined($test_ref->[$EXPECTED])) { + $test_ref->[$EXPECTED] = $test_ref->[$INPUT]; + } + my %value_of; + for my $i (0 .. $#{$test_ref}) { + $value_of{$i} = $test_ref->[$i][$LOC]; + if (exists($test_ref->[$i][$REV])) { + $value_of{$i} .= '@' . $test_ref->[$i][$REV]; + } + } + eval { + is( + $action_ref->($value_of{$INPUT}), $value_of{$EXPECTED}, + "$T: scalar context: $value_of{$INPUT}", + ); + }; + if ($@) { + fail("$T: scalar context: $value_of{$INPUT}: $@"); + } + eval { + is_deeply( + [$action_ref->(@{$test_ref->[$INPUT]})], + $test_ref->[$EXPECTED], + "$T: list context: $value_of{$INPUT}", + ); + }; + if ($@) { + fail("$T: list context: $value_of{$INPUT}: $@"); + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/e8/e876222b025f340833140c7b8806fea6a1e1d066.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/e8/e876222b025f340833140c7b8806fea6a1e1d066.svn-base new file mode 100644 index 0000000..cd2745a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/e8/e876222b025f340833140c7b8806fea6a1e1d066.svn-base @@ -0,0 +1,94 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A mock Fcm::ConfigSystem object +{ + package MockConfigSystem; + use base qw{Fcm::ConfigSystem}; + + our $LATEST_INVOKED_INSTANCE; + + ############################################################################ + # Returns the arguments to the last invoke() call + sub get_invoke_args { + my ($self) = @_; + return $self->{invoke_args}; + } + + ############################################################################ + # Does nothing but captures the arguments + sub invoke { + my ($self, %args) = @_; + $LATEST_INVOKED_INSTANCE = $self; + $self->{invoke_args} = \%args; + return 1; + } +} + +use Cwd; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::ConfigSystem'; + use_ok($class); + test_invoke($class); +} + +################################################################################ +# Tests normal usage of invoke() +sub test_invoke { + my ($class) = @_; + my $prefix = "invoke"; + my %TEST = ( + test1 => { + command => 'pig', + options => {'egg' => 1}, + arguments => ['bacon'], + expected_options => {FOO => undef, BAR_BAZ => undef, EGGS => 1}, + expected_arguments => 'bacon', + }, + test2 => { + command => 'pig', + options => {'foo' => 1, 'bar-baz' => 1}, + arguments => [], + expected_options => {FOO => 1, BAR_BAZ => 1, EGGS => undef}, + expected_arguments => cwd(), + } + ); + for my $key (keys(%TEST)) { + my $invoker = $class->new({ + command => $TEST{$key}{command}, + options => $TEST{$key}{options}, + arguments => $TEST{$key}{arguments}, + impl_class => 'MockConfigSystem', + cli2invoke_key_map => { + 'foo' => 'FOO', 'bar-baz' => 'BAR_BAZ', 'egg' => 'EGGS', + }, + }); + isa_ok($invoker, 'Fcm::CLI::Invoker::ConfigSystem', "$prefix: $key"); + $invoker->invoke(); + my $config_system_instance = $MockConfigSystem::LATEST_INVOKED_INSTANCE; + isa_ok( + $config_system_instance, + 'Fcm::ConfigSystem', + "$prefix: $key: Fcm::ConfigSystem", + ); + is( + $config_system_instance->cfg()->src(), + $TEST{$key}{expected_arguments}, + "$prefix: $key: cfg()->src()", + ); + is_deeply( + $config_system_instance->get_invoke_args(), + $TEST{$key}{expected_options}, + "$prefix: $key: invoke args", + ); + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ea/ea702852bad6b397d96b1beb339151d034ef3c3e.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ea/ea702852bad6b397d96b1beb339151d034ef3c3e.svn-base new file mode 100644 index 0000000..1c8aae4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ea/ea702852bad6b397d96b1beb339151d034ef3c3e.svn-base @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Interactive::InputGetter::GUI'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests usage of constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my $input_getter = $class->new({ + title => 'title-value', + message => 'message-value', + type => 'type-value', + default => 'default-value', + geometry => 'geometry-value', + }); + isa_ok($input_getter, $class); + is($input_getter->get_geometry(), 'geometry-value', "$prefix: geometry"); +} + +# TODO: tests the invoke method + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/ee14a98d1bcf9747e5a8da6c7a00dc98a0f4b539.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/ee14a98d1bcf9747e5a8da6c7a00dc98a0f4b539.svn-base new file mode 100644 index 0000000..e91b51a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/ee14a98d1bcf9747e5a8da6c7a00dc98a0f4b539.svn-base @@ -0,0 +1,43 @@ +#!/usr/bin/perl +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../../../lib"; + +use Test::More (tests => 3); + +if (!caller()) { + main(@ARGV); +} + +sub main { + my $CLASS = 'Fcm::Build::Fortran'; + use_ok($CLASS); + my $util = $CLASS->new(); + isa_ok($util, $CLASS); + test_extract_interface($util); +} + +sub test_extract_interface { + my ($util) = @_; + my $root = ($0 =~ qr{\A(.+)\.t\z}msx)[0]; + my $f90 = $root . '-extract-interface-source.f90'; + my $f90_interface = $root . '-extract-interface-result.f90'; + open(my($handle_for_source), '<', $f90) || die("$f90: $!"); + my @actual_lines = $util->extract_interface($handle_for_source); + close($handle_for_source); + open(my($handle_for_result), '<', $f90_interface) + || die("$f90_interface: $!"); + my @expected_lines = readline($handle_for_result); + close($handle_for_result); + is_deeply(\@actual_lines, \@expected_lines, 'extract_interface'); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/ee4accca6c7d6b5e732b56bc2cf30ff539629a8f.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/ee4accca6c7d6b5e732b56bc2cf30ff539629a8f.svn-base new file mode 100644 index 0000000..559f370 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/ee4accca6c7d6b5e732b56bc2cf30ff539629a8f.svn-base @@ -0,0 +1,101 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Carp qw{croak}; +use Fcm::Keyword::Entries; +use File::Basename qw{dirname}; +use File::Spec; +use File::Temp qw{tempdir}; +use IO::File; +use IO::Pipe; +use POSIX qw{WIFEXITED}; +use Test::More (tests => 17); + +my %VALUE_OF = ( + bar => { + 'bar3' => 3, + 'bar3.1' => 31, + 'bar3.14' => 314, + }, + baz => { + 'bear' => 4, + 'bee' => 6, + 'spider' => 8, + }, +); + +main(); + +sub main { + my $class = 'Fcm::Keyword::Loader::VC::Revision'; + use_ok($class); + test_constructor($class); + test_load_to($class); +} + +################################################################################ +# Tests simple usage of the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = "constructor"; + my $loader = $class->new({source => 'foo'}); + isa_ok($loader, $class); + is($loader->get_source(), 'foo', "$prefix: get_source()"); + ok($loader->load_to(), "$prefix: load_to"); # FIXME: should fail? +} + +################################################################################ +# Tests loading to an Fcm::Keyword::Entries object +sub test_load_to { + my ($class) = @_; + my $prefix = 'load to'; + my $temp_dir = tempdir(CLEANUP => 1); + my $repos = File::Spec->catfile($temp_dir, 'repos'); + WIFEXITED(system(qw{svnadmin create}, $repos)) + || croak("$repos: cannot create: $?"); + my $dump_file = File::Spec->catfile(dirname($0), 'Revision.dump'); + my $handle = IO::File->new($dump_file, 'r'); + if (!$handle) { + croak("$dump_file: cannot load: $!"); + } + my $dump = do{local $/; $handle->getline()}; + $handle->close(); + my $pipe = IO::Pipe->new(); + $pipe->writer(qw{svnadmin load -q}, $repos); + print($pipe $dump); + $pipe->close(); + if ($?) { + croak("$dump_file: cannot load: $?"); + } + my $repos_url = "file://$repos"; + my $loader = $class->new({source => $repos_url}); + my $entries = Fcm::Keyword::Entries->new(); + ok($loader->load_to($entries), "$prefix: nothing to load"); + for my $key (keys(%VALUE_OF)) { + my $url = "$repos_url/$key"; + my $loader = $class->new({source => $url}); + $loader->load_to($entries); + for my $rev_key (keys(%{$VALUE_OF{$key}})) { + my $entry = $entries->get_entry_by_key($rev_key); + if ($entry) { + is( + $entry->get_key(), + uc($rev_key), + "$prefix: by key: $rev_key", + ); + is( + $entries->get_entry_by_value($VALUE_OF{$key}{$rev_key}), + $entry, + "$prefix: by value: $rev_key: object", + ); + } + else { + fail("$prefix: by key: $rev_key"); + } + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/eec3c29f13d14f65b286d84ce7cc5a8bcbb2f880.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/eec3c29f13d14f65b286d84ce7cc5a8bcbb2f880.svn-base new file mode 100644 index 0000000..a83238a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/ee/eec3c29f13d14f65b286d84ce7cc5a8bcbb2f880.svn-base @@ -0,0 +1,136 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker; + +use Carp qw{croak}; +use Fcm::CLI::Exception; + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns the name of the (sub)command as given by the user +sub get_command { + my ($self) = @_; + return $self->{command}; +} + +################################################################################ +# Returns a reference to a hash containing the options +sub get_options { + my ($self) = @_; + return (wantarray() ? %{$self->{options}} : $self->{options}); +} + +################################################################################ +# Returns a reference to an array containing the arguments +sub get_arguments { + my ($self) = @_; + return (wantarray() ? @{$self->{arguments}} : $self->{arguments}); +} + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my $message = "command not implemented\n"; + $message .= sprintf("opts:"); + for my $key (sort keys(%{$self->get_options()})) { + my $value = $self->get_options()->{$key}; + $message .= sprintf( + " [%s=%s]", + $key, + ($value && ref($value) eq 'ARRAY' ? join(q{, }, @{$value}) : $value) + ); + } + $message .= sprintf("\n"); + $message .= sprintf("args: [%s]\n", join(q{] [}, $self->get_arguments())); + croak(Fcm::CLI::Exception->new({message => $message})); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker; + $invoker = Fcm::CLI::Invoker->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This is the base class for an invoker of a FCM sub-system from the CLI. +Sub-classes should override the invoke() method. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor. It accepts a hash reference as an argument. The element I<command> +should be set to the actual (sub)command as specified by the user. The element +I<options> should be a reference to a hash containing the specified command line +options. The element I<arguments> should be a reference to an array containing +the remaining command line arguments. + +=item get_command() + +Returns the actual (sub)command as specified by the user. + +=item get_options() + +Returns a hash containing the specified command line options. In scalar context, +returns a reference to the hash. + +=item get_arguments() + +Returns an array containing the (remaining) command line arguments. In scalar +context, returns a reference to the array. + +=item invoke() + +Sub-classes should override this method. Calling the method in this base +class causes the system to croak() with a +L<Fcm::CLI::Exception|Fcm::CLI::Exception>. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L<Fcm::CLI::Exception|Fcm::CLI::Exception> + +The C<invoke()> croak() with this exception. + +=back + +=head1 SEE ALSO + +L<Fcm::CLI::Exception|Fcm::CLI::Exception>, +L<Fcm::CLI::Subcommand|Fcm::CLI::Subcommand> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f0/f01c0fbfd6f0a4305cb1bc8e49f898497b0a7341.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f0/f01c0fbfd6f0a4305cb1bc8e49f898497b0a7341.svn-base new file mode 100644 index 0000000..be22fcb --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f0/f01c0fbfd6f0a4305cb1bc8e49f898497b0a7341.svn-base @@ -0,0 +1,105 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::CfgPrinter; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::Exception; +use Fcm::CfgFile; +use Fcm::Config; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my ($cfg_file) = $self->get_arguments(); + if (!$cfg_file) { + croak(Fcm::CLI::Exception->new({message => 'no CFGFILE specified'})); + } + my $cfg = Fcm::CfgFile->new(SRC => $cfg_file); + Fcm::Config->instance()->verbose(0); # suppress message printing to STDOUT + my $read = $cfg->read_cfg(); + if (!$read) { + croak(Fcm::Exception->new({message => sprintf( + "% :cannot read", $cfg_file, + )})); + } + $cfg->print_cfg($self->get_options()->{output}); + } + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::CfgPrinter + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::CfgPrinter; + $invoker = Fcm::CLI::Invoker::CfgPrinter->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L<Fcm::CLI::Invoker|Fcm::CLI::Invoker> an inherits all its +methods. An object of this class is used to invoke the pretty printer for FCM +configuration files. + +=head1 METHODS + +See L<Fcm::CLI::Invoker|Fcm::CLI::Invoker> for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the pretty printer for a FCM configuration file. + +If the I<output> option is set, output goes to the location specified by this +value. Otherwise, it prints to STDOUT. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L<Fcm::Exception|Fcm::Exception> + +The invoke() method can croak() with this exception if the configuration file +cannot be read. + +=item L<Fcm::CLI::Exception|Fcm::CLI::Exception> + +The invoke() method can croak() with this exception if no configuration file is +specified. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L<Fcm::CfgFile|Fcm::CfgFile>, +L<Fcm::CLI::Exception|Fcm::CLI::Exception>, +L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>, +L<Fcm::CLI::Subcommand|Fcm::CLI::Subcommand> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f2/f2cdef03a662d0af94013af717c989c7bfd9f029.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f2/f2cdef03a662d0af94013af717c989c7bfd9f029.svn-base new file mode 100644 index 0000000..aacdbf3 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f2/f2cdef03a662d0af94013af717c989c7bfd9f029.svn-base @@ -0,0 +1,894 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Config +# +# DESCRIPTION +# This is a class for reading and processing central and user configuration +# settings for FCM. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Config; + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use File::Basename; +use File::Spec::Functions; +use FindBin; +use POSIX qw/setlocale LC_ALL/; + +# FCM component modules +use Fcm::CfgFile; + +# Other declarations: +sub _get_hash_value; + +# Delimiter for setting and for list +our $DELIMITER = '::'; +our $DELIMITER_PATTERN = qr{::|/}; +our $DELIMITER_LIST = ','; + +my $INSTANCE; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $config = Fcm::Config->instance(); +# +# DESCRIPTION +# Returns an instance of this class. +# ------------------------------------------------------------------------------ + +sub instance { + my ($class) = @_; + if (!defined($INSTANCE)) { + $INSTANCE = $class->new(); + $INSTANCE->get_config(); + $INSTANCE->is_initialising(0); + } + return $INSTANCE; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Config->new (VERBOSE => $verbose); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Config class. +# +# ARGUMENTS +# VERBOSE - Set the verbose level of diagnostic output +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + # Ensure that all subsequent Subversion output is in UK English + if (setlocale (LC_ALL, 'en_GB')) { + $ENV{LANG} = 'en_GB'; + } + + my $self = { + initialising => 1, + central_config => undef, + user_config => undef, + user_id => undef, + verbose => exists $args{VERBOSE} ? $args{VERBOSE} : undef, + variable => {}, + + # Primary settings + setting => { + # Current command + FCM_COMMAND => &basename ($0), + + # Current FCM release identifier + FCM_RELEASE => '1-5', + + # Location of file with the last changed revision of the FCM trunk + FCM_REV_FILE => catfile (dirname ($FindBin::Bin), 'etc', 'fcm_rev'), + + # Fortran BLOCKDATA dependencies + BLD_BLOCKDATA => {}, + + # Copy dummy target + BLD_CPDUMMY => '$(FCM_DONEDIR)/FCM_CP.dummy', + + # No dependency check + BLD_DEP_N => {}, + + # Additional (PP) dependencies + BLD_DEP => {}, + BLD_DEP_PP => {}, + + # Excluded dependency + BLD_DEP_EXCL => { + '' => [ + # Fortran intrinsic modules + 'USE' . $DELIMITER . 'ISO_C_BINDING', + 'USE' . $DELIMITER . 'IEEE_EXCEPTIONS', + 'USE' . $DELIMITER . 'IEEE_ARITHMETIC', + 'USE' . $DELIMITER . 'IEEE_FEATURES', + + # Fortran intrinsic subroutines + 'OBJ' . $DELIMITER . 'CPU_TIME', + 'OBJ' . $DELIMITER . 'GET_COMMAND', + 'OBJ' . $DELIMITER . 'GET_COMMAND_ARGUMENT', + 'OBJ' . $DELIMITER . 'GET_ENVIRONMENT_VARIABLE', + 'OBJ' . $DELIMITER . 'MOVE_ALLOC', + 'OBJ' . $DELIMITER . 'MVBITS', + 'OBJ' . $DELIMITER . 'RANDOM_NUMBER', + 'OBJ' . $DELIMITER . 'RANDOM_SEED', + 'OBJ' . $DELIMITER . 'SYSTEM_CLOCK', + + # Dummy statements + 'OBJ' . $DELIMITER . 'NONE', + 'EXE' . $DELIMITER . 'NONE', + ], + }, + + # Extra executable dependencies + BLD_DEP_EXE => {}, + + # Dependency pattern for each type + BLD_DEP_PATTERN => { + H => q/^#\s*include\s*['"](\S+)['"]/, + USE => q/^\s*use\s+(\w+)/, + INTERFACE => q/^#?\s*include\s+['"](\S+##OUTFILE_EXT/ . $DELIMITER . + q/INTERFACE##)['"]/, + INC => q/^\s*include\s+['"](\S+)['"]/, + OBJ => q#^\s*(?:/\*|!)\s*depends\s*on\s*:\s*(\S+)#, + EXE => q/^\s*(?:#|;)\s*(?:calls|list|if|interface)\s*:\s*(\S+)/, + }, + + # Rename main program targets + BLD_EXE_NAME => {}, + + # Rename library targets + BLD_LIB => {'' => 'fcm_default'}, + + # Name of Makefile and run environment shell script + BLD_MISC => { + 'BLDMAKEFILE' => 'Makefile', + 'BLDRUNENVSH' => 'fcm_env.sh', + }, + + # PP flags + BLD_PP => {}, + + # Custom source file type + BLD_TYPE => {}, + + # Types that always need to be built + BLD_TYPE_ALWAYS_BUILD => 'PVWAVE' . + $DELIMITER_LIST . 'GENLIST' . + $DELIMITER_LIST . 'SQL', + + # Dependency scan types + BLD_TYPE_DEP => { + FORTRAN => 'USE' . + $DELIMITER . 'INTERFACE' . + $DELIMITER . 'INC' . + $DELIMITER . 'OBJ', + FPP => 'USE' . + $DELIMITER . 'INTERFACE' . + $DELIMITER . 'INC' . + $DELIMITER . 'H' . + $DELIMITER . 'OBJ', + CPP => 'H' . + $DELIMITER . 'OBJ', + C => 'H' . + $DELIMITER . 'OBJ', + SCRIPT => 'EXE', + }, + + # Dependency scan types for pre-processing + BLD_TYPE_DEP_PP => { + FPP => 'H', + CPP => 'H', + C => 'H', + }, + + # Types that cannot have duplicated targets + BLD_TYPE_NO_DUPLICATED_TARGET => '', + + # BLD_VPATH, each value must be a comma separate list + # '' translates to % + # 'FLAG' translates to {OUTFILE_EXT}{FLAG} + BLD_VPATH => { + BIN => q{}, + ETC => 'ETC', + DONE => join($DELIMITER_LIST, qw{DONE IDONE}), + FLAGS => 'FLAGS', + INC => q{}, + LIB => 'LIB', + OBJ => 'OBJ', + }, + + # Cache basename + CACHE => '.config', + CACHE_DEP => '.config_dep', + CACHE_DEP_PP => '.config_dep_pp', + CACHE_FILE_SRC => '.config_file_src', + + # Types of "inc" statements expandable CFG files + CFG_EXP_INC => 'BLD' . + $DELIMITER_LIST . 'EXT' . + $DELIMITER_LIST . 'FCM', + + # Configuration file labels that can be declared more than once + CFG_KEYWORD => 'USE' . + $DELIMITER_LIST . 'INC' . + $DELIMITER_LIST . 'TARGET' . + $DELIMITER_LIST . 'BLD_DEP_EXCL', + + # Labels for all types of FCM configuration files + CFG_LABEL => { + CFGFILE => 'CFG', # config file information + INC => 'INC', # "include" from an configuration file + + # Labels for central/user internal config setting + SETTING => 'SET', + + # Labels for systems that allow inheritance + DEST => 'DEST', # destination + USE => 'USE', # use (inherit) a previous configuration + + # Labels for bld and pck cfg + TARGET => 'TARGET', # BLD: declare targets, PCK: target of source file + + # Labels for bld cfg + BLD_BLOCKDATA => 'BLOCKDATA', # declare Fortran BLOCKDATA dependencies + BLD_DEP => 'DEP', # additional dependencies + BLD_DEP_N => 'NO_DEP', # no dependency check + BLD_DEP_EXCL => 'EXCL_DEP', # exclude automatic dependencies + BLD_DEP_EXE => 'EXE_DEP', # declare dependencies for program + BLD_EXE_NAME => 'EXE_NAME', # rename a main program + BLD_LIB => 'LIB', # rename library + BLD_PP => 'PP', # sub-package needs pre-process? + BLD_TYPE => 'SRC_TYPE', # custom source file type + DIR => 'DIR', # DEPRECATED, same as DEST + INFILE_EXT => 'INFILE_EXT', # change input file name extension type + INHERIT => 'INHERIT', # inheritance flag + NAME => 'NAME', # name the build + OUTFILE_EXT => 'OUTFILE_EXT', # change output file type extension + FILE => 'SRC', # declare a sub-package + SEARCH_SRC => 'SEARCH_SRC', # search src/ sub-directory? + TOOL => 'TOOL', # declare a tool + + # Labels for ext cfg + BDECLARE => 'BLD', # build declaration + CONFLICT => 'CONFLICT', # set conflict mode + DIRS => 'SRC', # declare source directory + EXPDIRS => 'EXPSRC', # declare expandable source directory + MIRROR => 'MIRROR', # DEPRECATED, same as RDEST::MIRROR_CMD + OVERRIDE => 'OVERRIDE', # DEPRECATED, replaced by CONFLICT + RDEST => 'RDEST', # declare remote destionation + REVISION => 'REVISION', # declare branch revision in a project + REVMATCH => 'REVMATCH', # branch revision must match changed revision + REPOS => 'REPOS', # declare branch in a project + VERSION => 'VERSION', # DEPRECATED, same as REVISION + }, + + # Default names of known FCM configuration files + CFG_NAME => { + BLD => 'bld.cfg', # build configuration file + EXT => 'ext.cfg', # extract configuration file + PARSED => 'parsed_', # as-parsed configuration file prefix + }, + + # Latest version of known FCM configuration files + CFG_VERSION => { + BLD => '1.0', # bld cfg + EXT => '1.0', # ext cfg + }, + + # Standard sub-directories for extract/build + DIR => { + BIN => 'bin', # executable + BLD => 'bld', # build + CACHE => '.cache', # cache + CFG => 'cfg', # configuration + DONE => 'done', # "done" + ETC => 'etc', # miscellaneous items + FLAGS => 'flags', # "flags" + INC => 'inc', # include + LIB => 'lib', # library + OBJ => 'obj', # object + PPSRC => 'ppsrc', # pre-processed source + SRC => 'src', # source + TMP => 'tmp', # temporary directory + }, + + # A flag to indicate whether the revision of a given branch for extract + # must match with the revision of a changed revision of the branch + EXT_REVMATCH => 0, # default is false (allow any revision) + + # Input file name extension and type + # (may overlap with output (below) and vpath (above)) + INFILE_EXT => { + # General extensions + 'f' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'for' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'ftn' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'f77' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'f90' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'SOURCE', + 'f95' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'SOURCE', + 'F' => 'FPP' . + $DELIMITER . 'SOURCE', + 'FOR' => 'FPP' . + $DELIMITER . 'SOURCE', + 'FTN' => 'FPP' . + $DELIMITER . 'SOURCE', + 'F77' => 'FPP' . + $DELIMITER . 'SOURCE', + 'F90' => 'FPP' . + $DELIMITER . 'FPP9X' . + $DELIMITER . 'SOURCE', + 'F95' => 'FPP' . + $DELIMITER . 'FPP9X' . + $DELIMITER . 'SOURCE', + 'c' => 'C' . + $DELIMITER . 'SOURCE', + 'cpp' => 'C' . + $DELIMITER . 'C++' . + $DELIMITER . 'SOURCE', + 'h' => 'CPP' . + $DELIMITER . 'INCLUDE', + 'o' => 'BINARY' . + $DELIMITER . 'OBJ', + 'obj' => 'BINARY' . + $DELIMITER . 'OBJ', + 'exe' => 'BINARY' . + $DELIMITER . 'EXE', + 'a' => 'BINARY' . + $DELIMITER . 'LIB', + 'sh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'ksh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'bash' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'csh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'pl' => 'SCRIPT' . + $DELIMITER . 'PERL', + 'pm' => 'SCRIPT' . + $DELIMITER . 'PERL', + 'py' => 'SCRIPT' . + $DELIMITER . 'PYTHON', + 'tcl' => 'SCRIPT' . + $DELIMITER . 'TCL', + 'pro' => 'SCRIPT' . + $DELIMITER . 'PVWAVE', + + # Local extensions + 'cfg' => 'CFGFILE', + 'h90' => 'CPP' . + $DELIMITER . 'INCLUDE', + 'inc' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'INCLUDE', + 'interface' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'INCLUDE' . + $DELIMITER . 'INTERFACE', + }, + + # Ignore input files matching the following names (comma-separated list) + INFILE_IGNORE => 'fcm_env.ksh' . + $DELIMITER_LIST . 'fcm_env.sh', + + # Input file name pattern and type + INFILE_PAT => { + '\w+Scr_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL', + '\w+Comp_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENTASK', + '\w+(?:IF|Interface)_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENIF', + '\w+Suite_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENSUITE', + '\w+List_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENLIST', + '\w+Sql_\w+' => 'SCRIPT' . + $DELIMITER . 'SQL', + }, + + # Input text file pattern and type + INFILE_TXT => { + '(?:[ck]|ba)?sh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'perl' => 'SCRIPT' . + $DELIMITER . 'PERL', + 'python' => 'SCRIPT' . + $DELIMITER . 'PYTHON', + 'tcl(?:sh)?|wish' => 'SCRIPT' . + $DELIMITER . 'TCL', + }, + + # Lock file + LOCK => { + BLDLOCK => 'fcm.bld.lock', # build lock file + EXTLOCK => 'fcm.ext.lock', # extract lock file + }, + + # Output file type and extension + # (may overlap with input and vpath (above)) + OUTFILE_EXT => { + CFG => '.cfg', # FCM configuration file + DONE => '.done', # "done" files for compiled source + ETC => '.etc', # "etc" dummy file + EXE => '.exe', # binary executables + FLAGS => '.flags', # "flags" files, compiler flags config + IDONE => '.idone', # "done" files for included source + INTERFACE => '.interface', # interface for F90 subroutines/functions + LIB => '.a', # archive object library + MOD => '.mod', # compiled Fortran module information files + OBJ => '.o', # compiled object files + PDONE => '.pdone', # "done" files for pre-processed files + TAR => '.tar', # TAR archive + }, + + # Build commands and options (i.e. tools) + TOOL => { + SHELL => '/bin/sh', # Default shell + + CPP => 'cpp', # C pre-processor + CPPFLAGS => '-C', # CPP flags + CPP_INCLUDE => '-I', # CPP flag, specify "include" path + CPP_DEFINE => '-D', # CPP flag, define macro + CPPKEYS => '', # CPP keys (definition macro) + + CC => 'cc', # C compiler + CFLAGS => '', # CC flags + CC_COMPILE => '-c', # CC flag, compile only + CC_OUTPUT => '-o', # CC flag, specify output file name + CC_INCLUDE => '-I', # CC flag, specify "include" path + CC_DEFINE => '-D', # CC flag, define macro + + FPP => 'cpp', # Fortran pre-processor + FPPFLAGS => '-P -traditional', # FPP flags + FPP_INCLUDE => '-I', # FPP flag, specify "include" path + FPP_DEFINE => '-D', # FPP flag, define macro + FPPKEYS => '', # FPP keys (definition macro) + + FC => 'f90', # Fortran compiler + FFLAGS => '', # FC flags + FC_COMPILE => '-c', # FC flag, compile only + FC_OUTPUT => '-o', # FC flag, specify output file name + FC_INCLUDE => '-I', # FC flag, specify "include" path + FC_MODSEARCH => '', # FC flag, specify "module" path + FC_DEFINE => '-D', # FC flag, define macro + + LD => '', # linker + LDFLAGS => '', # LD flags + LD_OUTPUT => '-o', # LD flag, specify output file name + LD_LIBSEARCH => '-L', # LD flag, specify "library" path + LD_LIBLINK => '-l', # LD flag, specify link library + + AR => 'ar', # library archiver + ARFLAGS => 'rs', # AR flags + + MAKE => 'make', # make command + MAKEFLAGS => '', # make flags + MAKE_FILE => '-f', # make flag, path to Makefile + MAKE_SILENT => '-s', # make flag, silent diagnostic + MAKE_JOB => '-j', # make flag, number of jobs + + INTERFACE => 'file', # name interface after file/program + GENINTERFACE => '', # Fortran 9x interface generator + + DIFF3 => 'diff3', # extract diff3 merge + DIFF3FLAGS => '-E -m', # DIFF3 flags + GRAPHIC_DIFF => 'xxdiff', # graphical diff tool + GRAPHIC_MERGE=> 'xxdiff', # graphical merge tool + }, + + # List of tools that are local to FCM, (will not be exported to a Makefile) + TOOL_LOCAL => 'CPP' . + $DELIMITER_LIST . 'CPPFLAGS' . + $DELIMITER_LIST . 'CPP_INCLUDE' . + $DELIMITER_LIST . 'CPP_DEFINE' . + $DELIMITER_LIST . 'DIFF3' . + $DELIMITER_LIST . 'DIFF3_FLAGS' . + $DELIMITER_LIST . 'FPP' . + $DELIMITER_LIST . 'FPPFLAGS' . + $DELIMITER_LIST . 'FPP_INCLUDE' . + $DELIMITER_LIST . 'FPP_DEFINE' . + $DELIMITER_LIST . 'GRAPHIC_DIFF' . + $DELIMITER_LIST . 'GRAPHIC_MERGE' . + $DELIMITER_LIST . 'MAKE' . + $DELIMITER_LIST . 'MAKEFLAGS' . + $DELIMITER_LIST . 'MAKE_FILE' . + $DELIMITER_LIST . 'MAKE_SILENT' . + $DELIMITER_LIST . 'MAKE_JOB' . + $DELIMITER_LIST . 'INTERFACE' . + $DELIMITER_LIST . 'GENINTERFACE' . + $DELIMITER_LIST . 'MIRROR' . + $DELIMITER_LIST . 'REMOTE_SHELL', + + # List of tools that allow sub-package declarations + TOOL_PACKAGE => 'CPPFLAGS' . + $DELIMITER_LIST . 'CPPKEYS' . + $DELIMITER_LIST . 'CFLAGS' . + $DELIMITER_LIST . 'FPPFLAGS' . + $DELIMITER_LIST . 'FPPKEYS' . + $DELIMITER_LIST . 'FFLAGS' . + $DELIMITER_LIST . 'LD' . + $DELIMITER_LIST . 'LDFLAGS' . + $DELIMITER_LIST . 'INTERFACE' . + $DELIMITER_LIST . 'GENINTERFACE', + + # Supported tools for compilable source + TOOL_SRC_PP => { + FPP => { + COMMAND => 'FPP', + FLAGS => 'FPPFLAGS', + PPKEYS => 'FPPKEYS', + INCLUDE => 'FPP_INCLUDE', + DEFINE => 'FPP_DEFINE', + }, + + C => { + COMMAND => 'CPP', + FLAGS => 'CPPFLAGS', + PPKEYS => 'CPPKEYS', + INCLUDE => 'CPP_INCLUDE', + DEFINE => 'CPP_DEFINE', + }, + }, + + # Supported tools for compilable source + TOOL_SRC => { + FORTRAN => { + COMMAND => 'FC', + FLAGS => 'FFLAGS', + OUTPUT => 'FC_OUTPUT', + INCLUDE => 'FC_INCLUDE', + }, + + FPP => { + COMMAND => 'FC', + FLAGS => 'FFLAGS', + PPKEYS => 'FPPKEYS', + OUTPUT => 'FC_OUTPUT', + INCLUDE => 'FC_INCLUDE', + DEFINE => 'FC_DEFINE', + }, + + C => { + COMMAND => 'CC', + FLAGS => 'CFLAGS', + PPKEYS => 'CPPKEYS', + OUTPUT => 'CC_OUTPUT', + INCLUDE => 'CC_INCLUDE', + DEFINE => 'CC_DEFINE', + }, + }, + + # FCM URL keyword and prefix, FCM revision keyword, and FCM Trac URL + URL => {}, + URL_REVISION => {}, + + URL_BROWSER_MAPPING => {}, + URL_BROWSER_MAPPING_DEFAULT => { + LOCATION_COMPONENT_PATTERN + => qr{\A // ([^/]+) /+ ([^/]+)_svn /+(.*) \z}xms, + BROWSER_URL_TEMPLATE + => 'http://{1}/projects/{2}/intertrac/source:{3}{4}', + BROWSER_REV_TEMPLATE => '@{1}', + }, + + # Default web browser + WEB_BROWSER => 'firefox', + }, + }; + + # Backward compatibility: the REPOS setting is equivalent to the URL setting + $self->{setting}{REPOS} = $self->{setting}{URL}; + + # Alias the REVISION and TRAC setting to URL_REVISION and URL_TRAC + $self->{setting}{REVISION} = $self->{setting}{URL_REVISION}; + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in the "new" method. +# ------------------------------------------------------------------------------ + +for my $name (qw/central_config user_config user_id verbose/) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'central_config') { + # Central configuration file + if (-r catfile (dirname ($FindBin::Bin), 'etc', 'fcm.cfg')) { + $self->{$name} = catfile ( + dirname ($FindBin::Bin), 'etc', 'fcm.cfg' + ); + + } elsif (-r catfile ($FindBin::Bin, 'fcm.cfg')) { + $self->{$name} = catfile ($FindBin::Bin, 'fcm.cfg'); + } + + } elsif ($name eq 'user_config') { + # User configuration file + my $home = (getpwuid ($<))[7]; + $home = $ENV{HOME} if not defined $home; + $self->{$name} = catfile ($home, '.fcm') + if defined ($home) and -r catfile ($home, '.fcm'); + + } elsif ($name eq 'user_id') { + # User ID of current process + my $user = (getpwuid ($<))[0]; + $user = $ENV{LOGNAME} if not defined $user; + $user = $ENV{USER} if not defined $user; + $self->{$name} = $user; + + } elsif ($name eq 'verbose') { + # Verbose mode + $self->{$name} = exists $ENV{FCM_VERBOSE} ? $ENV{FCM_VERBOSE} : 1; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->is_initialising(); +# +# DESCRIPTION +# Returns true if this object is initialising. +# ------------------------------------------------------------------------------ +sub is_initialising { + my ($self, $value) = @_; + if (defined($value)) { + $self->{initialising} = $value; + } + return $self->{initialising}; +} + + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in the "new" method. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (qw/variable/) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $setting = $obj->setting (@labels); +# $obj->setting (\@labels, $setting); +# +# DESCRIPTION +# This method returns/sets an item under the setting hash table. The depth +# within the hash table is given by the list of arguments @labels, which +# should match with the keys in the multi-dimension setting hash table. +# ------------------------------------------------------------------------------ + +sub setting { + my $self = shift; + + if (@_) { + my $arg1 = shift; + my $s = $self->{setting}; + + if (ref ($arg1) eq 'ARRAY') { + # Assign setting + # ------------------------------------------------------------------------ + my $value = shift; + + while (defined (my $label = shift @$arg1)) { + if (exists $s->{$label}) { + if (ref $s->{$label} eq 'HASH') { + $s = $s->{$label}; + + } else { + $s->{$label} = $value; + last; + } + + } else { + if (@$arg1) { + $s->{$label} = {}; + $s = $s->{$label}; + + } else { + $s->{$label} = $value; + } + } + } + + } else { + # Get setting + # ------------------------------------------------------------------------ + return _get_hash_value ($s->{$arg1}, @_) if exists $s->{$arg1}; + } + } + + return undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj->get_config (); +# +# DESCRIPTION +# This method reads the configuration settings from the central and the user +# configuration files. +# ------------------------------------------------------------------------------ + +sub get_config { + my $self = shift; + + $self->_read_config_file ($self->central_config); + $self->_read_config_file ($self->user_config); + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj->_read_config_file (); +# +# DESCRIPTION +# This internal method reads a configuration file and assign values to the +# attributes of the current instance. +# ------------------------------------------------------------------------------ + +sub _read_config_file { + my $self = shift; + my $config_file = $_[0]; + + if (!$config_file || !-f $config_file || !-r $config_file) { + return; + } + + my $cfgfile = Fcm::CfgFile->new (SRC => $config_file, TYPE => 'FCM'); + $cfgfile->read_cfg (); + + LINE: for my $line (@{ $cfgfile->lines }) { + next unless $line->label; + + # "Environment variables" start with $ + if ($line->label =~ /^\$([A-Za-z_]\w*)$/) { + $ENV{$1} = $line->value; + next LINE; + } + + # "Settings variables" start with "set" + if ($line->label_starts_with_cfg ('SETTING')) { + my @tags = $line->label_fields; + shift @tags; + @tags = map {uc} @tags; + $self->setting (\@tags, $line->value); + next LINE; + } + + # Not a standard setting variable, put in internal variable list + (my $label = $line->label) =~ s/^\%//; + $self->variable ($label, $line->value); + } + + 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $ref = _get_hash_value (arg1, arg2, ...); +# +# DESCRIPTION +# This internal method recursively gets a value from a multi-dimensional +# hash. +# ------------------------------------------------------------------------------ + +sub _get_hash_value { + my $value = shift; + + while (defined (my $arg = shift)) { + if (exists $value->{$arg}) { + $value = $value->{$arg}; + + } else { + return undef; + } + } + + return $value; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f7/f7d117d1bba80932af6d63f60f31f868f8c7c81f.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f7/f7d117d1bba80932af6d63f60f31f868f8c7c81f.svn-base new file mode 100644 index 0000000..526f54d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f7/f7d117d1bba80932af6d63f60f31f868f8c7c81f.svn-base @@ -0,0 +1,412 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Config::Default; + +use Fcm::CLI::Option; +use Fcm::CLI::Subcommand; + +my %DESCRIPTION_OF = ( + # -------------------------------------------------------------------------- + BROWSER => <<'END_DESCRIPTION', +If TARGET is specified, it must be a FCM URL keyword, a Subversion URL or the +path to a local working copy. If not specified, the current working directory +is assumed to be a working copy. If the --browser option is specified, the +specified web browser command is used to launch the repository browser. +Otherwise, it attempts to use the default browser from the configuration +setting. +END_DESCRIPTION + # -------------------------------------------------------------------------- + BUILD => <<'END_DESCRIPTION', +The path to a CFGFILE may be provided. Otherwise, the build system searches the +default locations for a bld cfg file. + +If no option is specified, the options "-s 5 -t all -j 1 -v 1" are assumed. + +If the option for full build is specified, the sub-directories created by +previous builds will be removed, so that the current build can start cleanly. + +The -s option can be used to limit the actions performed by the build system up +to a named stage. The stages are: + "1", "s" or "setup" - stage 1, setup + "2", "pp" or "pre_process" - stage 2, pre-process + "3", "gd" or "generate_dependency" - stage 3, generate dependency + "4", "gi" or "generate_interface" - stage 4, generate Fortran 9X interface + "5", "m", "make" - stage 5, make + +If a colon separated list of targets is specified using the -t option, the +default targets specified in the configuration file will not be used. + +If archive mode is switched on, build sub-directories that are only used in the +build process will be archived to TAR files. The default is off. + +If specified, the verbose level must be an integer greater than 0. Verbose +level 0 is the quiet mode. Increasing the verbose level will increase the +amount of diagnostic output. + +When a build is invoked, it sets up a lock file in the build root directory. +The lock is normally removed at the end of the build. While the lock file is in +place, the build commands invoked in the same root directory will fail. If +you need to bypass this check for whatever reason, you can invoke the build +system with the --ignore-lock option. +END_DESCRIPTION + # -------------------------------------------------------------------------- + CFG_PRINTER => <<'END_DESCRIPTION', +If no option is specified, the output will be sent to standard output. +END_DESCRIPTION + # -------------------------------------------------------------------------- + EXTRACT => <<'END_DESCRIPTION', +The path to a CFG file may be provided. Otherwise, the extract system searches +the default locations for an ext cfg file. + +If no option is specified, the system will attempt an incremental extract where +appropriate. + +If specified, the verbose level must be an integer greater than 0. Verbose +level 0 is the quiet mode. Increasing the verbose level will increase the +amount of diagnostic output. + +When an extract is invoked, it sets up a lock file in the extract destination +root directory. The lock is normally removed at the end of the extract. While +the lock file is in place, other extract commands invoked in the same +destination root directory will fail. If you need to bypass this check for +whatever reason, you can invoke the extract system with the --ignore-lock +option. +END_DESCRIPTION + # -------------------------------------------------------------------------- + EXTRACT_CONFIG_COMPARATOR => <<'END_DESCRIPTION', +Compares the extract configurations of two similar extract configuration files +CFGFILE1 and CFGFILE2. + +In normal mode with verbosity level 2 or above, displays the change log of each +revision. + +In wiki mode, print revision tables in wiki format. The argument to the --wiki +option must be the Subversion URL or FCM URL keyword of a FCM project +associated with the intended Trac system. The --verbose option has no effect +in wiki mode. +END_DESCRIPTION + # -------------------------------------------------------------------------- + GUI => <<'END_DESCRIPTION', +The optional argument PATH modifies the initial working directory of the GUI. +END_DESCRIPTION + # -------------------------------------------------------------------------- + KEYWORD => <<'END_DESCRIPTION', +If no argument is specified, prints registered location keywords. Otherwise, +prints the implied location keywords and revision keywords for the specified +target. +END_DESCRIPTION +); + +my %OPTION_OF = ( + ARCHIVE => Fcm::CLI::Option->new({ + name => 'archive', + letter => 'a', + description => 'archives sub-directories on success', + }), + + BROWSER => Fcm::CLI::Option->new({ + name => 'browser', + letter => 'b', + description => 'specifies the web browser command', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + CLEAN => Fcm::CLI::Option->new({ + name => 'clean', + description => 'cleans the destination', + }), + + FULL => Fcm::CLI::Option->new({ + name => 'full', + letter => 'f', + description => 'runs in full mode', + }), + + HELP => Fcm::CLI::Option->new({ + name => 'help', + letter => 'h', + description => 'prints help', + is_help => 1, + }), + + IGNORE_LOCK => Fcm::CLI::Option->new({ + name => 'ignore-lock', + description => 'ignores lock file', + }), + + JOBS => Fcm::CLI::Option->new({ + name => 'jobs', + letter => 'j', + description => 'number of parallel jobs', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + OUTPUT => Fcm::CLI::Option->new({ + name => 'output', + letter => 'o', + description => 'sends output to the specified file', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + STAGE => Fcm::CLI::Option->new({ + name => 'stage', + letter => 's', + description => 'runs command up to a named stage', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + TARGETS => Fcm::CLI::Option->new({ + name => 'targets', + letter => 't', + delimiter => ':', + description => 'list of build targets, delimited by (:)', + has_arg => Fcm::CLI::Option->ARRAY_ARG, + }), + + VERBOSITY => Fcm::CLI::Option->new({ + name => 'verbose', + letter => 'v', + description => 'verbose level', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + WIKI => Fcm::CLI::Option->new({ + name => 'wiki', + letter => 'w', + description => 'print revision tables in wiki format', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), +); + +my %SUBCOMMAND_OF = ( + BRANCH => Fcm::CLI::Subcommand->new({ + names => ['branch', 'br'], + synopsis => 'branch utilities', + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), + + BROWSER => Fcm::CLI::Subcommand->new({ + names => ['trac', 'www'], + synopsis => 'invokes the browser for a version controlled target', + usage => '[OPTIONS...] [TARGET]', + description => $DESCRIPTION_OF{BROWSER}, + invoker_class => 'Fcm::CLI::Invoker::Browser', + options => [ + $OPTION_OF{BROWSER}, + $OPTION_OF{HELP}, + ], + }), + + BUILD => Fcm::CLI::Subcommand->new({ + names => ['build', 'bld'], + synopsis => 'invokes the build system', + usage => '[OPTIONS...] [CFGFILE]', + description => $DESCRIPTION_OF{BUILD}, + invoker_class => 'Fcm::CLI::Invoker::ConfigSystem', + invoker_config => { + impl_class => 'Fcm::Build', + cli2invoke_key_map => { + 'archive' => 'ARCHIVE', + 'clean' => 'CLEAN', + 'full' => 'FULL', + 'ignore-lock' => 'IGNORE_LOCK', + 'jobs' => 'JOBS', + 'stage' => 'STAGE', + 'targets' => 'TARGETS', + }, + }, + options => [ + $OPTION_OF{ARCHIVE}, + $OPTION_OF{CLEAN}, + $OPTION_OF{FULL}, + $OPTION_OF{HELP}, + $OPTION_OF{IGNORE_LOCK}, + $OPTION_OF{JOBS}, + $OPTION_OF{STAGE}, + $OPTION_OF{TARGETS}, + $OPTION_OF{VERBOSITY}, + ], + }), + + CFG_PRINTER => Fcm::CLI::Subcommand->new({ + names => ['cfg'], + synopsis => 'invokes the CFG file pretty printer', + usage => '[OPTIONS...] [CFGFILE]', + description => $DESCRIPTION_OF{CFG_PRINTER}, + invoker_class => 'Fcm::CLI::Invoker::CfgPrinter', + options => [ + $OPTION_OF{HELP}, + $OPTION_OF{OUTPUT}, + ], + }), + + CM => Fcm::CLI::Subcommand->new({ + names => [qw{ + add + blame praise annotate ann + cat + checkout co + cleanup + commit ci + copy cp + delete del remove rm + diff di + export + import + info + list ls + lock + log + merge + mkdir + move mv rename ren + propdel pdel pd + propedit pedit pe + propget pget pg + proplist plist pl + propset pset ps + resolved + revert + status stat st + switch sw + unlock + update up + }], + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), + + CONFLICTS => Fcm::CLI::Subcommand->new({ + names => ['conflicts', 'cf'], + synopsis => 'resolves conflicts in your working copy', + usage => '[PATH]', + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), + + EXTRACT => Fcm::CLI::Subcommand->new({ + names => ['extract', 'ext'], + synopsis => 'invokes the extract system', + usage => '[OPTIONS...] [CFGFILE]', + description => $DESCRIPTION_OF{EXTRACT}, + invoker_class => 'Fcm::CLI::Invoker::ConfigSystem', + invoker_config => { + impl_class => 'Fcm::Extract', + cli2invoke_key_map => { + 'clean' => 'CLEAN', + 'full' => 'FULL', + 'ignore-lock' => 'IGNORE_LOCK', + }, + }, + options => [ + $OPTION_OF{CLEAN}, + $OPTION_OF{FULL}, + $OPTION_OF{HELP}, + $OPTION_OF{IGNORE_LOCK}, + $OPTION_OF{VERBOSITY}, + ], + }), + + EXTRACT_CONFIG_COMPARATOR => Fcm::CLI::Subcommand->new({ + names => ['cmp-ext-cfg'], + synopsis => 'invokes the extract configuration files comparator', + usage => '[OPTIONS...] CFGFILE1 CFGFILE2', + description => $DESCRIPTION_OF{EXTRACT_CONFIG_COMPARATOR}, + invoker_class => 'Fcm::CLI::Invoker::ExtractConfigComparator', + options => [ + $OPTION_OF{HELP}, + $OPTION_OF{VERBOSITY}, + $OPTION_OF{WIKI}, + ], + }), + + GUI => Fcm::CLI::Subcommand->new({ + names => ['gui'], + synopsis => 'invokes the GUI wrapper for code management commands', + usage => '[PATH]', + description => $DESCRIPTION_OF{GUI}, + invoker_class => 'Fcm::CLI::Invoker::GUI', + }), + + HELP => Fcm::CLI::Subcommand->new({ + names => ['help', q{?}, q{}], + synopsis => 'displays the usage of this program or its subcommands', + usage => '[SUBCOMMAND]', + description => q{}, + invoker_class => 'Fcm::CLI::Invoker::Help', + options => [$OPTION_OF{HELP}], + }), + + KEYWORD => Fcm::CLI::Subcommand->new({ + names => ['keyword-print', 'kp'], + synopsis => 'prints registered location and/or revision keywords', + usage => '[TARGET]', + description => $DESCRIPTION_OF{KEYWORD}, + invoker_class => 'Fcm::CLI::Invoker::KeywordPrinter', + options => [$OPTION_OF{HELP}], + }), + + MKPATCH => Fcm::CLI::Subcommand->new({ + names => ['mkpatch'], + synopsis => 'creates patches from specified revisions of a URL', + usage => '[OPTIONS] URL [OUTDIR]', + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), +); + +our @CORE_SUBCOMMANDS = ( + $SUBCOMMAND_OF{HELP}, + $SUBCOMMAND_OF{BUILD}, + $SUBCOMMAND_OF{CFG_PRINTER}, +); + +our @VC_SUBCOMMANDS = ( + $SUBCOMMAND_OF{BRANCH}, + $SUBCOMMAND_OF{BROWSER}, + $SUBCOMMAND_OF{CONFLICTS}, + $SUBCOMMAND_OF{EXTRACT}, + $SUBCOMMAND_OF{EXTRACT_CONFIG_COMPARATOR}, + $SUBCOMMAND_OF{GUI}, + $SUBCOMMAND_OF{KEYWORD}, + $SUBCOMMAND_OF{MKPATCH}, + $SUBCOMMAND_OF{CM}, +); + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Config::Default + +=head1 SYNOPSIS + + use Fcm::CLI::Config::Default; + @core_subcommands = @Fcm::CLI::Config::Default::CORE_SUBCOMMANDS; + @vc_subcommands = @Fcm::CLI::Config::Default::VC_SUBCOMMANDS; + +=head1 DESCRIPTION + +This module stores the default configuration of the FCM command line interface. +It should only be used by L<Fcm::CLI::Config|Fcm::CLI::Config>. + +=head1 SEE ALSO + +L<Fcm::CLI::Config|Fcm::CLI::Config>, +L<Fcm::CLI::Invoker|Fcm::CLI::Invoker>, +L<Fcm::CLI::Subcommand|Fcm::CLI::Subcommand>, +L<Fcm::CLI::Option|Fcm::CLI::Option> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f9/f9a74ae8a01b86a18669c4263bd84eb722241d92.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f9/f9a74ae8a01b86a18669c4263bd84eb722241d92.svn-base new file mode 100644 index 0000000..22c6c88 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/f9/f9a74ae8a01b86a18669c4263bd84eb722241d92.svn-base @@ -0,0 +1,74 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::CLI::Option; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Subcommand'; + use_ok($class); + test_constructor($class); + test_has_a_name($class); + test_as_string($class); +} + +################################################################################ +# Tests the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my %OPTION_OF = ( + description => 'description value', + invoker_class => 'invoker_class value', + invoker_config => 'invoker_config value', + is_vc => 'is_vc value', + names => 'names value', + options => 'options value', + synopsis => 'synopsis value', + usage => 'usage value', + ); + my $subcommand = Fcm::CLI::Subcommand->new(\%OPTION_OF); + isa_ok($subcommand, $class, $prefix); + for my $key (keys(%OPTION_OF)) { + my $getter = index($key, 'is') == 0 ? $key : "get_$key"; + is($subcommand->$getter(), $OPTION_OF{$key}, "$prefix: $getter"); + } +} + +################################################################################ +# Tests match a string name to a subcommand +sub test_has_a_name { + my ($class) = @_; + my $prefix = 'has a name'; + my @NAMES = ('foo', 'bar', 'baz'); + my $subcommand = $class->new({names => \@NAMES}); + for my $name (@NAMES) { + ok($subcommand->has_a_name($name), "$prefix: $name"); + } + for my $name (qw{egg ham mayo}) { + ok(!$subcommand->has_a_name($name), "$prefix: $name"); + } +} + +################################################################################ +# Tests string representation of a subcommand +sub test_as_string { + my ($class) = @_; + my $prefix = 'as string'; + my %OPTION_OF = ( + 'foo (bar, baz)' => ['foo', 'bar', 'baz'], + 'foo (bar)' => ['foo', 'bar'], + 'foo' => ['foo'], + q{} => [], + ); + for my $key (keys(%OPTION_OF)) { + my $subcommand = $class->new({names => $OPTION_OF{$key}}); + is($subcommand->as_string(), $key, "$prefix: $key"); + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/fb/fb71c3d9053787cb664ed09a49e9af60ae3591ad.svn-base b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/fb/fb71c3d9053787cb664ed09a49e9af60ae3591ad.svn-base new file mode 100644 index 0000000..6a6213d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/.svn/pristine/fb/fb71c3d9053787cb664ed09a49e9af60ae3591ad.svn-base @@ -0,0 +1,4 @@ +FCM release 1-5 created from revision 3579. + +For further details please refer to the release notes +which can be found in the directory doc/release_notes. diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/wc.db b/NEMO_4.0.4_surge/ext/FCM/.svn/wc.db new file mode 100644 index 0000000..8e7321b Binary files /dev/null and b/NEMO_4.0.4_surge/ext/FCM/.svn/wc.db differ diff --git a/NEMO_4.0.4_surge/ext/FCM/.svn/wc.db-journal b/NEMO_4.0.4_surge/ext/FCM/.svn/wc.db-journal new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/ext/FCM/COPYRIGHT.txt b/NEMO_4.0.4_surge/ext/FCM/COPYRIGHT.txt new file mode 100644 index 0000000..2a74773 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/COPYRIGHT.txt @@ -0,0 +1,109 @@ +!------------------------------------------------------------------------------! +! Flexible Configuration Management Software License ! +! ! +! Please read this Software Licence as you will be bound by its terms ! +! if you use the Software ! +!------------------------------------------------------------------------------! + +The Licensor: +------------- + +The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom +-------------------------------------------------------------------------------- + +1. Licence. +----------- + +The Met Office grants you a non-exclusive, royalty free; world-wide, +transferable Licence to use, modify, copy and distribute the Flexible +Configuration Management software ("the software") accompanying this License +providing: + +a. you undertake to provide to the Met Office a copy of any modifications made + by you on the same terms contained within this licence agreement; + +b. modified files carry prominent notices stating that you changed the files + and the date of change; + +c. distribution of original or modified files is made free of charge under the + terms of this Licence; + +d. the appropriate copyright notices, the above copyright notice and a + disclaimer of warranty is included with the distribution. + +2. Ownership. +------------- + +The Flexible Configuration Management software is Crown copyright and is +reproduced with the permission of Met Office under delegated authority from +the Controller of HMSO. The software and documentation are provided to you to +allow you to exercise your rights under this License, which is granted to you. + +3. Duration. +------------ + +This license will remain in effect until terminated. + +4. Termination. +--------------- + +You may terminate this license at any time by removing all copies of the +software from your system. This License will terminate immediately without +notice from us if you fail to comply with any of the provisions of this +License or in the event of your breaching the terms of this licence you are +given notice that the license has been terminated. Upon termination you will +delete all copies of the software and any related documentation. + +5. Disclaimer of Warranty. +-------------------------- + +a. THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES, + INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY + AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY + REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND + PLATFORMS. + +b. In no event does the Met Office warrant that the software or related + documentation will satisfy your requirements, that the software and + documentation will be without errors or defects or that the operation of + the software will be uninterrupted. + +c. IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES, INCLUDING + BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE SOFTWARE + OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF THE MET + OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +6. General Provisions. +---------------------- + +a. You will not do anything, relating to this software that will bring the Met + Office into disrepute. + +b. You will not use the name of the Met Office or any other contributor to + endorse or promote any products derived from the software without the + written permission of the Met Office. + +7. Acknowledgements. +-------------------- + +The logic to extract the calling interfaces of top level subroutines and +functions from a Fortran source file is adapted from a script developed at +ECMWF and is provided by kind permission of ECMWF under the same terms of this +Licence. + +8. Entire Agreement. +-------------------- + +This License constitutes the entire agreement between us with respect to your +rights or warranties for using the software and related documentation. If any +provision of this agreement is determined to be invalid or unenforceable the +remaining provisions shall continue in full force. + +9. Governing Law. +----------------- + +This Agreement is governed by and construed in accordance with the Laws of +England. + +-------------------------------------------------------------------------------- + � British Crown copyright 2006-10. diff --git a/NEMO_4.0.4_surge/ext/FCM/LICENSE.html b/NEMO_4.0.4_surge/ext/FCM/LICENSE.html new file mode 100644 index 0000000..f749f39 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/LICENSE.html @@ -0,0 +1,154 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> + +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> + <title>Flexible Configuration Management Software License + + + + + + +

Flexible Configuration Management Software License

+ +

Please read this Software Licence as you will be bound by its terms if + you use the Software

+ +

The Licensor:

+ +

The Met Office of FitzRoy Road, Exeter EX1 3PB, United Kingdom

+ +

1. Licence.

+ +

The Met Office grants you a non-exclusive, royalty free; world-wide, + transferable Licence to use, modify, copy and distribute the Flexible + Configuration Management software ("the software") accompanying this License + providing:

+ +
    +
  1. you undertake to provide to the Met Office a copy of any modifications + made by you on the same terms contained within this licence agreement;
    2. + +
  2. modified files carry prominent notices stating that you changed the + files and the date of change;
    3. + +
  3. distribution of original or modified files is made free of charge under + the terms of this Licence;
    4. + +
  4. the appropriate copyright notices, the above copyright notice and a + disclaimer of warranty is included with the distribution.
    5. +
+ +

2. Ownership.

+ +

The Flexible Configuration Management software is Crown copyright and is + reproduced with the permission of Met Office under delegated authority from + the Controller of HMSO. The software and documentation are provided to you to + allow you to exercise your rights under this License, which is granted to + you.

+ +

3. Duration.

+ +

This license will remain in effect until terminated.

+ +

4. Termination.

+ +

You may terminate this license at any time by removing all copies of the + software from your system. This License will terminate immediately without + notice from us if you fail to comply with any of the provisions of this + License or in the event of your breaching the terms of this licence you are + given notice that the license has been terminated. Upon termination you will + delete all copies of the software and any related documentation.

+ +

5. Disclaimer of Warranty.

+ +
    +
  1. THE MET OFFICE DISCLAIMS ALL WARRANTIES, REPRESENTATIONS AND PROMISES, + INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF SATISFACTORY QUALITY + AND FIT FOR THE PURPOSE. NEITHER DOES THE MET OFFICE MAKE ANY + REPRESENTATIONS AS TO COMPATABILITY WITH YOUR OPERATING SYSTEMS AND + PLATFORMS.
    2. + +
  2. In no event does the Met Office warrant that the software or related + documentation will satisfy your requirements, that the software and + documentation will be without errors or defects or that the operation of + the software will be uninterrupted.
    3. + +
  3. IN NO EVENT WILL THE MET OFFICE BE LIABLE FOR ANY OTHER DAMAGES, + INCLUDING BUT NOT LIMITED TO DAMAGES FOR LOSS OF PROFITS DATA OR USE OF THE + SOFTWARE OR FOR ANY INDIRECT, INCIDENTAL OR CONSEQUENTIAL DAMAGES, EVEN IF + THE MET OFFICE HAS BEEN SPECIFICALLY ADVISED OF THE POSSIBILITY OF SUCH + DAMAGES.
    4. +
+ +

6. General Provisions.

+ +
    +
  1. You will not do anything, relating to this software that will bring the + Met Office into disrepute.
    2. + +
  2. You will not use the name of the Met Office or any other contributor to + endorse or promote any products derived from the software without the + written permission of the Met Office.
    3. +
+ +

7. Acknowledgements.

+ +

The logic to extract the calling interfaces of top level subroutines and + functions from a Fortran source file is adapted from a script developed at + ECMWF and is provided by kind permission of ECMWF under the same terms of this + Licence.

+ +

8. Entire Agreement.

+ +

This License constitutes the entire agreement between us with respect to + your rights or warranties for using the software and related documentation. + If any provision of this agreement is determined to be invalid or + unenforceable the remaining provisions shall continue in full force.

+ +

9. Governing Law.

+ +

This Agreement is governed by and construed in accordance with the Laws of + England.

+ +
+ © British Crown copyright 2006-10. +
+ + diff --git a/NEMO_4.0.4_surge/ext/FCM/README b/NEMO_4.0.4_surge/ext/FCM/README new file mode 100644 index 0000000..6a6213d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/README @@ -0,0 +1,4 @@ +FCM release 1-5 created from revision 3579. + +For further details please refer to the release notes +which can be found in the directory doc/release_notes. diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm b/NEMO_4.0.4_surge/ext/FCM/bin/fcm new file mode 100755 index 0000000..7722685 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm @@ -0,0 +1,66 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Fcm::CLI; +use Fcm::Interactive; + +if (!caller()) { + main(@ARGV); +} + +sub main { + local(@ARGV) = @_; + if (@ARGV && $ARGV[0] eq 'gui-internal') { + shift(@ARGV); + Fcm::Interactive::set_impl( + 'Fcm::Interactive::InputGetter::GUI', + {geometry => shift(@ARGV)}, + ); + } + Fcm::CLI::invoke(); +} + +__END__ + +=head1 NAME + +fcm + +=head1 SYNOPSIS + +fcm SUBCOMMAND [OPTIONS] [ARGUMENTS] + +=head1 OVERVIEW + +B is the command line client for code management commands, the extract +system and the build system of the Flexible Configuration Management (FCM) +system. For full detail of the system, please refer to the FCM user guide, +which you should receive with this distribution in both HTML and PDF formats. + +Run "fcm help" to access the built-in tool documentation. + +=head1 AUTHOR + +FCM Team L. +Please feedback any bug reports or feature requests to us by e-mail. + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +You can use this release of B freely under the terms of the FCM LICENSE, +which you should receive with this distribution. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm_graphic_diff b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_graphic_diff new file mode 100755 index 0000000..b96d3d5 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_graphic_diff @@ -0,0 +1,96 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use Getopt::Long qw{GetOptions}; + +# ------------------------------------------------------------------------------ + +my ($u, @label); +GetOptions ('u' => \$u, 'L=s' => \@label); + +# Check existence of files +for my $i (0 .. 1) { + die $ARGV[$i], ': not found, abort' unless $ARGV[$i] and -f $ARGV[$i]; +} + +my ($old, $new) = @ARGV; + +if ($old =~ m#.svn/empty-file$#) { + print 'Skipping new file', "\n\n"; + +} elsif ($new =~ m#.svn/empty-file$#) { + print 'Skipping deleted file', "\n\n"; + +} elsif (-z $old) { + print 'Skipping as old file is empty (or does not exist)', "\n\n"; + +} elsif (-z $new) { + print 'Skipping as new file is empty (or deleted)', "\n\n"; + +} elsif (-B $new) { + print 'Skipping binary file', "\n\n"; + +} else { + # Print descriptions of files + if (@label >= 2) { + print '--- ', $label[0], "\n", '+++ ', $label[1], "\n\n"; + } + + # FCM_GRAPHIC_DIFF is the graphical diff tool command + my $cmd = (exists $ENV{FCM_GRAPHIC_DIFF} ? $ENV{FCM_GRAPHIC_DIFF} : 'xxdiff'); + + if ($cmd) { + my @options = (); + + # Set options for labels if appropriate + if (@label >= 2) { + if ($cmd eq 'tkdiff') { + # Use tkdiff + @options = ('-L', $label[0], '-L', $label[1]); + + } elsif ($cmd eq 'xxdiff') { + # Use xxdiff + @options = ('--title1', $label[0], '--title2', $label[1]); + } + } + + # Execute the command + my @command = ($cmd, @options, $old, $new); + exec (@command) or die 'Cannot execute: ', join (' ', @command); + } + + exit; +} + +__END__ + +=head1 NAME + +fcm_graphic_diff + +=head1 SYNOPSIS + + fcm_graphic_diff [-u] [-L OLD_DESC] [-L NEW_DESC] OLD NEW + +=head1 DESCRIPTION + +Wrapper script which invokes a graphical diff tool. Its interface is +compatible with the "svn diff" command and can be used in combination with +its "--diff-cmd" option. The command prints the OLD_DESC and NEW_DESC if +they are both set. The two arguments OLD and NEW must be set and are the +files to compare. The graphical diff tool invoked depends on the value of +the FCM_GRAPHIC_DIFF environment variable. The command exits if the +environment variable is not set. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm_graphic_merge b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_graphic_merge new file mode 100755 index 0000000..9928009 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_graphic_merge @@ -0,0 +1,83 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +my ($base, $mine, $older, $yours) = @ARGV; + +# FCM_GRAPHIC_MERGE is the graphical merge tool command +my $cmd = (exists $ENV{FCM_GRAPHIC_MERGE} ? $ENV{FCM_GRAPHIC_MERGE} : 'xxdiff'); + +my $rc = 2; +my $out = ''; +if ($cmd eq 'xxdiff') { + # Launch xxdiff + my @command = ($cmd, qw/-m -M/, $base, qw/-O -X/, $mine, $older, $yours); + my ($cmd_out) = qx(@command); + my $cmd_rc = $?; + + # Parse output from xxdiff + if ($cmd_out) { + chomp $cmd_out; + if ($cmd_out eq 'NODECISION') { + $out = 'made no decision'; + $rc = 1; + + } elsif ($cmd_out eq 'MERGED' and $cmd_rc) { + $out = 'not resolved all the conflicts'; + $rc = 1; + + } else { + $out = lc ($cmd_out); + $rc = 0; + } + + } else { + print STDERR $cmd, ': failed, abort.', "\n"; + } + +} else { + # Throw error for unknown/undefined graphic merge tool + print STDERR ($cmd ? $cmd . ': ' : ''), + 'unknown/undefined graphic merge tool, abort.', "\n"; +} + +if ($rc == 1) { + # Merge unresolved + print 'You have ', $out, '.', "\n"; + +} elsif ($rc == 0) { + # Merge resolved + print 'You ', $out, ' all the changes.', "\n"; +} + +exit $rc; + +__END__ + +=head1 NAME + +fcm_graphic_merge + +=head1 SYNOPSIS + + fcm_graphic_merge BASE MINE OLDER YOURS + +=head1 DESCRIPTION + +Wrapper script which invokes a graphical merge tool. It returns 0 on +success, 1 if conflicts not resolved or 2 on failure. (This is similar to +GNU diff3.) BASE is the file you want to save the merge result into. MINE +is the original file. YOURS is the file you want MINE to merge with. OLDER +is the common ancestor of MINE and YOURS. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm_gui b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_gui new file mode 100755 index 0000000..1644080 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_gui @@ -0,0 +1,1346 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Cwd; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Timer; +use Fcm::Util; +use File::Basename; +use File::Spec; +use Tk; +use Tk::ROText; + +# ------------------------------------------------------------------------------ + +# Argument +if (@ARGV) { + my $dir = shift @ARGV; + chdir $dir if -d $dir; +} + +# Get configuration settings +my $config = Fcm::Config->new (); +$config->get_config (); + +# ------------------------------------------------------------------------------ + +# FCM subcommands +my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT + UPDATE SWITCH/; + +# Subcommands allowed when CWD is not a WC +my @nwc_subcmds = qw/CHECKOUT BRANCH/; + +# Subcommands allowed, when CWD is a WC +my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE + SWITCH/; + +# Subcommands that apply to WC only +my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE + SWITCH/; + +# Subcommands that apply to top level WC only +my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/; + +# Selected subcommand +my $selsubcmd = ''; + +# Selected subcommand is running? +my $cmdrunning = 0; + +# PID of running subcommand +my $cmdpid = undef; + +# List of subcommand frames +my %subcmd_f; + +# List of subcommand buttons +my %subcmd_b; + +# List of subcommand button help strings +my %subcmd_help = ( + BRANCH => 'list information about, create or delete a branch.', + CHECKOUT => 'check out a working copy from a repository.', + STATUS => 'print the status of working copy files and directories.', + DIFF => 'display the differences in modified files.', + ADD => 'put files and directories under version control.', + DELETE => 'remove files and directories from version control.', + MERGE => 'merge changes into your working copy.', + CONFLICTS => 'use a graphical tool to resolve conflicts in your working copy.', + COMMIT => 'send changes from your working copy to the repository.', + UPDATE => 'bring changes from the repository into your working copy.', + SWITCH => 'update your working copy to a different URL.', +); + +for (keys %subcmd_help) { + $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' . + $subcmd_help{$_}; +} + +# List of subcommand button bindings (key name and underline position) +my %subcmd_bind = ( + BRANCH => {KEY => '', U => 0}, + CHECKOUT => {KEY => '', U => 5}, + STATUS => {KEY => '', U => 0}, + DIFF => {KEY => '', U => 0}, + ADD => {KEY => '', U => 0}, + DELETE => {KEY => '', U => 4}, + MERGE => {KEY => '', U => 0}, + CONFLICTS => {KEY => '', U => 3}, + COMMIT => {KEY => '', U => 0}, + UPDATE => {KEY => '', U => 0}, + SWITCH => {KEY => '', U => 1}, +); + +# List of subcommand variables +my %subcmdvar = ( + CWD => cwd (), + WCT => '', + CWD_URL => '', + WCT_URL => '', + + BRANCH => { + OPT => 'info', + URL => '', + NAME => '', + TYPE => 'DEV', + REVFLAG => 'NORMAL', + REV => '', + TICKET => '', + SRCTYPE => 'trunk', + S_CHD => 0, + S_SIB => 0, + S_OTH => 0, + VERBOSE => 0, + OTHER => '', + }, + + CHECKOUT => { + URL => '', + REV => 'HEAD', + PATH => '', + OTHER => '', + }, + + STATUS => { + USEWCT => 0, + UPDATE => 0, + VERBOSE => 0, + OTHER => '', + }, + + DIFF => { + USEWCT => 0, + TOOL => 'graphical', + BRANCH => 0, + URL => '', + OTHER => '', + }, + + ADD => { + USEWCT => 0, + CHECK => 1, + OTHER => '', + }, + + DELETE => { + USEWCT => 0, + CHECK => 1, + OTHER => '', + }, + + MERGE => { + USEWCT => 1, + SRC => '', + MODE => 'automatic', + DRYRUN => 0, + VERBOSE => 0, + REV => '', + OTHER => '', + }, + + CONFLICTS => { + USEWCT => 0, + OTHER => '', + }, + + COMMIT => { + USEWCT => 1, + DRYRUN => 0, + OTHER => '', + }, + + UPDATE => { + USEWCT => 1, + OTHER => '', + }, + + SWITCH => { + USEWCT => 1, + URL => '', + OTHER => '', + }, +); + +# List of action buttons +my %action_b; + +# List of action button help strings +my %action_help = ( + QUIT => 'Quit fcm gui', + HELP => 'Print help to the output text box for the selected sub-command', + CLEAR => 'Clear the output text box', + RUN => 'Run the selected sub-command', +); + +# List of action button bindings +my %action_bind = ( + QUIT => {KEY => '', U => undef}, + HELP => {KEY => '' , U => undef}, + CLEAR => {KEY => '' , U => 1}, + RUN => {KEY => '' , U => 0}, +); + +# List of branch subcommand options +my %branch_opt = ( + INFO => undef, + CREATE => undef, + DELETE => undef, + LIST => undef, +); + +# List of branch create types +my %branch_type = ( + 'DEV' => undef, + 'DEV::SHARE' => undef, + 'TEST' => undef, + 'TEST::SHARE' => undef, + 'PKG' => undef, + 'PKG::SHARE' => undef, + 'PKG::CONFIG' => undef, + 'PKG::REL' => undef, +); + +# List of branch create source type +my %branch_srctype = ( + TRUNK => undef, + BRANCH => undef, +); + +# List of branch create revision prefix option +my %branch_revflag = ( + NORMAL => undef, + NUMBER => undef, + NONE => undef, +); + +# List of branch info/delete options +my %branch_info_opt = ( + S_CHD => 'Show children', + S_SIB => 'Show siblings', + S_OTH => 'Show other', + VERBOSE => 'Print extra information', +); + +# List of diff display options +my %diff_display_opt = ( + default => 'Default mode', + graphical => 'Graphical tool', + trac => 'Trac (only for diff relative to the base of the branch)', +); + +# Text in the status bar +my $statustext = ''; + +# ------------------------------------------------------------------------------ + +my $mw = MainWindow->new (); + +my $mw_title = 'FCM GUI'; +$mw->title ($mw_title); + +# Frame containing subcommand selection buttons +my $top_f = $mw->Frame ()->grid ( + '-row' => 0, + '-column' => 0, + '-sticky' => 'w', +); + +# Frame containing subcommand options +my $mid_f = $mw->Frame ()->grid ( + '-row' => 1, + '-column' => 0, + '-sticky' => 'ew', +); + +# Frame containing action buttons +my $bot_f = $mw->Frame ()->grid ( + '-row' => 2, + '-column' => 0, + '-sticky' => 'ew', +); + +# Text box to display output +my $out_t = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid ( + '-row' => 3, + '-column' => 0, + '-sticky' => 'news', +); + +# Text box - allow scroll with mouse wheel +$out_t->bind ( + '<4>' => sub { + $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif; + }, +); + +$out_t->bind ( + '<5>' => sub { + $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif; + }, +); + +# Status bar +$mw->Label ( + '-textvariable' => \$statustext, + '-relief' => 'groove', +)->grid ( + '-row' => 4, + '-column' => 0, + '-sticky' => 'ews', +); + +# Main window grid configure +{ + my ($cols, $rows) = $mw->gridSize (); + $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1); + $mw->gridRowconfigure ( 3, '-weight' => 1); +} + +# Frame grid configure +{ + my ($cols, $rows) = $mid_f->gridSize (); + $bot_f->gridColumnconfigure (3, '-weight' => 1); +} + +$mid_f->gridRowconfigure (0, '-weight' => 1); +$mid_f->gridColumnconfigure (0, '-weight' => 1); + +# ------------------------------------------------------------------------------ + +# Buttons to select subcommands +{ + my $col = 0; + for my $name (@subcmds) { + $subcmd_b{$name} = $top_f->Button ( + '-text' => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)), + '-command' => [\&button_clicked, $name], + '-width' => 8, + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + + $subcmd_b{$name}->bind ('', sub {$statustext = $subcmd_help{$name}}); + $subcmd_b{$name}->bind ('', sub {$statustext = ''}); + + $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U}) + if defined $subcmd_bind{$name}{U}; + + $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke}); + } +} + +# ------------------------------------------------------------------------------ + +# Frames to contain subcommands options +{ + my %row = (); + + for my $name (@subcmds) { + $subcmd_f{$name} = $mid_f->Frame (); + $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1); + + $row{$name} = 0; + + # Widgets common to all sub-commands + $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + } + + # Widgets common to all sub-commands that apply to working copies + for my $name (@wco_subcmds) { + my @labtxts = ( + 'Corresponding URL: ', + 'Working copy top: ', + 'Corresponding URL: ', + ); + my @varrefs = \( + $subcmdvar{URL_CWD}, + $subcmdvar{WCT}, + $subcmdvar{URL_WCT}, + ); + + for my $i (0 .. $#varrefs) { + $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + } + + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Apply sub-command to working copy top', + '-variable' => \($subcmdvar{$name}{USEWCT}), + '-state' => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + + # Widget for the Branch sub-command + { + my $name = 'BRANCH'; + + # Radio buttons to select the sub-option of the branch sub-command + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_opt) { + my $opt = lc $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $opt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{OPT}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + + # Label and entry box for specifying URL + $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{URL}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and entry box for specifying create branch name + $subcmd_f{$name}->Label ( + '-text' => 'Branch name (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{NAME}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and entry box for specifying create branch source revision + $subcmd_f{$name}->Label ( + '-text' => 'Source revision (create/list only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{REV}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and radio buttons box for specifying create branch type + $subcmd_f{$name}->Label ( + '-text' => 'Branch type (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_type) { + my $txt = lc $key; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{TYPE}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Label and radio buttons box for specifying create source type + $subcmd_f{$name}->Label ( + '-text' => 'Source type (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_srctype) { + my $txt = lc $key; + my $opt = lc $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{SRCTYPE}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Label and radio buttons box for specifying create prefix option + $subcmd_f{$name}->Label ( + '-text' => 'Prefix option (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (sort keys %branch_revflag) { + my $txt = lc $key; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{REVFLAG}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Label and entry box for specifying ticket number + $subcmd_f{$name}->Label ( + '-text' => 'Related Trac ticket(s) (create only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{TICKET}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Check button for info/delete + # --show-children, --show-siblings, --show-other, --verbose + $subcmd_f{$name}->Label ( + '-text' => 'Options for info/delete only: ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + + for my $key (sort keys %branch_info_opt) { + $opt_f->Checkbutton ( + '-text' => $branch_info_opt{$key}, + '-variable' => \($subcmdvar{$name}{$key}), + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + } + + # Widget for the Checkout sub-command + { + my $name = 'CHECKOUT'; + + # Label and entry boxes for specifying URL and revision + my @labtxts = ( + 'URL: ', + 'Revision: ', + 'Path: ', + ); + my @varrefs = \( + $subcmdvar{$name}{URL}, + $subcmdvar{$name}{REV}, + $subcmdvar{$name}{PATH}, + ); + + for my $i (0 .. $#varrefs) { + $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => $varrefs[$i], + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + } + + # Widget for the Status sub-command + { + my $name = 'STATUS'; + + # Checkbuttons for various options + my @labtxts = ( + 'Display update information', + 'Print extra information', + ); + my @varrefs = \( + $subcmdvar{$name}{UPDATE}, + $subcmdvar{$name}{VERBOSE}, + ); + + for my $i (0 .. $#varrefs) { + $subcmd_f{$name}->Checkbutton ( + '-text' => $labtxts[$i], + '-variable' => $varrefs[$i], + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + } + + # Widget for the Diff sub-command + { + my $name = 'DIFF'; + + my $entry; + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Show differences relative to the base of the branch', + '-variable' => \($subcmdvar{$name}{BRANCH}), + '-command' => sub { + $entry->configure ( + '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'), + ); + }, + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + # Label and radio buttons box for specifying tool + $subcmd_f{$name}->Label ( + '-text' => 'Display diff in: ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (qw/default graphical trac/) { + my $txt = $diff_display_opt{$key}; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{TOOL}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + $entry = $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{URL}), + '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + + # Widget for the Add/Delete sub-command + for my $name (qw/ADD DELETE/) { + + # Checkbuttons for various options + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Check for files or directories not under version control', + '-variable' => \($subcmdvar{$name}{CHECK}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + + # Widget for the Merge sub-command + { + my $name = 'MERGE'; + + # Label and radio buttons box for specifying merge mode + $subcmd_f{$name}->Label ( + '-text' => 'Mode: ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + + { + my $opt_f = $subcmd_f{$name}->Frame ()->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'w', + ); + + my $col = 0; + for my $key (qw/automatic custom reverse/) { + my $txt = lc $key; + my $opt = $key; + + $branch_opt{$key} = $opt_f->Radiobutton ( + '-text' => $txt, + '-value' => $opt, + '-variable' => \($subcmdvar{$name}{MODE}), + '-state' => 'normal', + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => 'w', + ); + } + } + + # Check buttons for dry-run + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Dry run', + '-variable' => \($subcmdvar{$name}{DRYRUN}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + # Check buttons for verbose mode + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Print extra information', + '-variable' => \($subcmdvar{$name}{VERBOSE}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + + # Label and entry boxes for specifying merge source + $subcmd_f{$name}->Label ( + '-text' => 'Source (automatic/custom only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{SRC}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + + # Label and entry boxes for specifying merge revision (range) + $subcmd_f{$name}->Label ( + '-text' => 'Revision (custom/reverse only): ', + )->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{REV}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + + # Widget for the Commit sub-command + { + my $name = 'COMMIT'; + + # Checkbuttons for various options + $subcmd_f{$name}->Checkbutton ( + '-text' => 'Dry run', + '-variable' => \($subcmdvar{$name}{DRYRUN}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'w', + ); + } + + # Widget for the Switch sub-command + { + my $name = 'SWITCH'; + + # Label and entry boxes for specifying switch URL + $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{URL}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } + + # Widgets common to all sub-commands + for my $name (@subcmds) { + $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid ( + '-row' => $row{$name}, + '-column' => 0, + '-sticky' => 'w', + ); + $subcmd_f{$name}->Entry ( + '-textvariable' => \($subcmdvar{$name}{OTHER}), + )->grid ( + '-row' => $row{$name}++, + '-column' => 1, + '-sticky' => 'ew', + ); + } +} + +# ------------------------------------------------------------------------------ + +# Buttons to perform main actions +{ + my $col = 0; + for my $name (qw/QUIT HELP CLEAR RUN/) { + $action_b{$name} = $bot_f->Button ( + '-text' => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)), + '-command' => [\&button_clicked, $name], + '-width' => 8, + )->grid ( + '-row' => 0, + '-column' => $col++, + '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'), + ); + + $action_b{$name}->bind ('', sub {$statustext = $action_help{$name}}); + $action_b{$name}->bind ('', sub {$statustext = ''}); + + $action_b{$name}->configure ('-underline' => $action_bind{$name}{U}) + if defined $action_bind{$name}{U}; + + $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke}); + } +} + +&change_cwd ($subcmdvar{CWD}); + +# ------------------------------------------------------------------------------ + +# Handle the situation when the user attempts to quit the window while a +# sub-command is running + +$mw->protocol ('WM_DELETE_WINDOW', sub { + if (defined $cmdpid) { + my $ans = $mw->messageBox ( + '-title' => $mw_title, + '-message' => $selsubcmd . ' is still running. Really quit?', + '-type' => 'YesNo', + '-default' => 'No', + ); + + if ($ans eq 'Yes') { + kill 9, $cmdpid; # Need to kill the sub-process before quitting + + } else { + return; # Do not quit + } + } + + exit; +}); + +MainLoop; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &change_cwd ($dir); +# +# DESCRIPTION +# Change current working directory to $dir +# ------------------------------------------------------------------------------ + +sub change_cwd { + my $dir = $_[0]; + my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds); + + for my $subcmd (@subcmds) { + if (grep {$_ eq $subcmd} @allowed_subcmds) { + $subcmd_b{$subcmd}->configure ('-state' => 'normal'); + + } else { + $subcmd_b{$subcmd}->configure ('-state' => 'disabled'); + } + } + + &display_subcmd_frame ($allowed_subcmds[0]) + if not grep {$_ eq $selsubcmd} @allowed_subcmds; + + chdir $dir; + $subcmdvar{CWD} = $dir; + + if (&is_wc ($dir)) { + $subcmdvar{WCT} = &get_wct ($dir); + $subcmdvar{URL_CWD} = &get_url_of_wc ($dir); + $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}); + + $branch_opt{INFO} ->configure ('-state' => 'normal'); + $branch_opt{DELETE}->configure ('-state' => 'normal'); + $subcmdvar{BRANCH}{OPT} = 'info'; + + } else { + $branch_opt{INFO} ->configure ('-state' => 'disabled'); + $branch_opt{DELETE}->configure ('-state' => 'disabled'); + $subcmdvar{BRANCH}{OPT} = 'create'; + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &button_clicked ($name); +# +# DESCRIPTION +# Call back function to handle a click on a command button named $name. +# ------------------------------------------------------------------------------ + +sub button_clicked { + my $name = $_[0]; + + if (grep {$_ eq $name} keys %subcmd_b) { + &display_subcmd_frame ($name); + + } elsif ($name eq 'CLEAR') { + $out_t->delete ('1.0', 'end'); + + } elsif ($name eq 'QUIT') { + exit; + + } elsif ($name eq 'HELP') { + &invoke_cmd ('help ' . lc ($selsubcmd)); + + } elsif ($name eq 'RUN') { + &invoke_cmd (&setup_cmd ($selsubcmd)); + + } else { + $out_t->insert ('end', $name . ': function to be implemented' . "\n"); + $out_t->yviewMoveto (1); + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &display_subcmd_frame ($name); +# +# DESCRIPTION +# Change selected subcommand to $name, and display the frame containing the +# widgets for configuring the options and arguments of that subcommand. +# ------------------------------------------------------------------------------ + +sub display_subcmd_frame { + my $name = $_[0]; + + if ($selsubcmd ne $name and not $cmdrunning) { + $subcmd_b{$name }->configure ('-relief' => 'sunken'); + $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd; + + $subcmd_f{$name }->grid ('-sticky' => 'new'); + $subcmd_f{$selsubcmd}->gridForget if $selsubcmd; + + $selsubcmd = $name; + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $pos = &get_wm_pos (); +# +# DESCRIPTION +# Returns the position part of the geometry string of the main window. +# ------------------------------------------------------------------------------ + +sub get_wm_pos { + my $geometry = $mw->geometry (); + $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/; + return $1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $command = &setup_cmd ($name); +# +# DESCRIPTION +# Setup the the system command for the sub-command $name. +# ------------------------------------------------------------------------------ + +sub setup_cmd { + my $name = $_[0]; + my $cmd = ''; + + if ($name eq 'BRANCH') { + $cmd .= lc ($name); + if ($subcmdvar{$name}{OPT} eq 'create') { + $cmd .= ' -c --svn-non-interactive'; + $cmd .= ' -n ' . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME}; + $cmd .= ' -t ' . $subcmdvar{$name}{TYPE}; + $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG}; + $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET}; + $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch'; + + } elsif ($subcmdvar{$name}{OPT} eq 'delete') { + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + $cmd .= ' -d --svn-non-interactive'; + + } elsif ($subcmdvar{$name}{OPT} eq 'list') { + $cmd .= ' -l'; + $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + + } else { + $cmd .= ' -i'; + $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD}; + $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB}; + $cmd .= ' --show-other' if $subcmdvar{$name}{S_OTH}; + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + } + $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'CHECKOUT') { + $cmd .= lc ($name); + $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + $cmd .= ' ' . $subcmdvar{$name}{URL}; + $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH}; + + } elsif ($name eq 'STATUS') { + $cmd .= lc ($name); + $cmd .= ' -u' if $subcmdvar{$name}{UPDATE}; + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'DIFF') { + $cmd .= lc ($name); + $cmd .= ' -g' if $subcmdvar{$name}{TOOL} eq 'graphical'; + + if ($subcmdvar{$name}{BRANCH}) { + $cmd .= ' -b'; + $cmd .= ' -t' if $subcmdvar{$name}{TOOL} eq 'trac'; + $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL}; + } + + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'ADD' or $name eq 'DELETE') { + $cmd .= lc ($name); + $cmd .= ' -c' if $subcmdvar{$name}{CHECK}; + $cmd .= ' --non-interactive' + if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'MERGE') { + $cmd .= lc ($name); + + if ($subcmdvar{$name}{MODE} ne 'automatic') { + $cmd .= ' --' . $subcmdvar{$name}{MODE}; + $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV}; + } + + $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN}; + $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE}; + $cmd .= ' ' . $subcmdvar{$name}{SRC} if $subcmdvar{$name}{SRC}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'CONFLICTS') { + $cmd .= lc ($name); + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'COMMIT') { + $cmd .= lc ($name); + $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN}; + $cmd .= ' --svn-non-interactive'; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'SWITCH') { + $cmd .= lc ($name); + $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL}; + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } elsif ($name eq 'UPDATE') { + $cmd .= lc ($name); + $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER}; + + } + + return $cmd; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &invoke_cmd ($cmd); +# +# DESCRIPTION +# Invoke the command $cmd. +# ------------------------------------------------------------------------------ + +sub invoke_cmd { + my $cmd = $_[0]; + return unless $cmd; + + my $disp_cmd = 'fcm ' . $cmd; + $cmd = (index ($cmd, 'help ') == 0) + ? $disp_cmd + : ('fcm gui-internal ' . &get_wm_pos () . ' ' . $cmd); + + # Change directory to working copy top if necessary + if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) { + chdir $subcmdvar{WCT}; + $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n"); + $out_t->yviewMoveto (1); + } + + # Report start of command + $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start')); + $out_t->yviewMoveto (1); + + # Open the command as a pipe + if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') { + # Disable all action buttons + $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b); + $cmdrunning = 1; + + # Set up a file event to read output from the command + $mw->fileevent (\*CMD, readable => sub { + if (sysread CMD, my ($buf), 1024) { + # Insert text into the output text box as it becomes available + $out_t->insert ('end', $buf); + $out_t->yviewMoveto (1); + + } else { + # Delete the file event and close the file when the command finishes + $mw->fileevent(\*CMD, readable => ''); + close CMD; + $cmdpid = undef; + + # Check return status + if ($?) { + $out_t->insert ( + 'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n", + ); + $out_t->yviewMoveto (1); + } + + # Report end of command + $out_t->insert ('end', timestamp_command ($disp_cmd, 'End')); + $out_t->yviewMoveto (1); + + # Change back to CWD if necessary + if ($subcmdvar{$selsubcmd}{USEWCT} and + $subcmdvar{WCT} ne $subcmdvar{CWD}) { + chdir $subcmdvar{CWD}; + $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n"); + $out_t->yviewMoveto (1); + } + + # Enable all action buttons again + $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b); + $cmdrunning = 0; + + # If the command is "checkout", change directory to working copy + if (lc ($selsubcmd) eq 'checkout' && $subcmdvar{CHECKOUT}{URL}) { + my $url = Fcm::Keyword::expand($subcmdvar{CHECKOUT}{URL}); + my $dir = $subcmdvar{CHECKOUT}{PATH} + ? $subcmdvar{CHECKOUT}{PATH} + : basename $url; + $dir = File::Spec->rel2abs ($dir); + &change_cwd ($dir); + + # If the command is "switch", change URL + } elsif (lc ($selsubcmd) eq 'switch') { + $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1); + $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1); + } + } + 1; + }); + + } else { + $mw->messageBox ( + '-title' => 'Error', + '-message' => 'Error running "' . $cmd . '"', + '-icon' => 'error', + ); + } + + return; +} + +# ------------------------------------------------------------------------------ + +__END__ + +=head1 NAME + +fcm_gui + +=head1 SYNOPSIS + +fcm_gui [DIR] + +=head1 DESCRIPTION + +The fcm_gui command is a simple graphical user interface for some of the +commands of the FCM system. The optional argument DIR modifies the initial +working directory. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm_internal b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_internal new file mode 100755 index 0000000..c477b5d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_internal @@ -0,0 +1,615 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use Fcm::Timer qw{timestamp_command}; + +# Function declarations +sub catfile; +sub basename; +sub dirname; + +# ------------------------------------------------------------------------------ + +# Module level variables +my %unusual_tool_name = (); + +# ------------------------------------------------------------------------------ + +MAIN: { + # Name of program + my $this = basename $0; + + # Arguments + my $subcommand = shift @ARGV; + my ($function, $type) = split /:/, $subcommand; + + my ($srcpackage, $src, $target, $requirepp, @objects, @blockdata); + + if ($function eq 'archive') { + ($target, @objects) = @ARGV; + + } elsif ($function eq 'load') { + ($srcpackage, $src, $target, @blockdata) = @ARGV; + + } else { + ($srcpackage, $src, $target, $requirepp) = @ARGV; + } + + # Set up hash reference for all the required information + my %info = ( + SRCPACKAGE => $srcpackage, + SRC => $src, + TYPE => $type, + TARGET => $target, + REQUIREPP => $requirepp, + OBJECTS => \@objects, + BLOCKDATA => \@blockdata, + ); + + # Get list of unusual tools + my $i = 0; + while (my $label = &get_env ('FCM_UNUSUAL_TOOL_LABEL' . $i)) { + my $value = &get_env ('FCM_UNUSUAL_TOOL_VALUE' . $i); + $unusual_tool_name{$label} = $value; + $i++; + } + + # Invoke the action + my $rc = 0; + if ($function eq 'compile') { + $rc = &compile (\%info); + + } elsif ($function eq 'load') { + $rc = &load (\%info); + + } elsif ($function eq 'archive') { + $rc = &archive (\%info); + + } else { + print STDERR $this, ': incorrect usage, abort'; + $rc = 1; + } + + # Throw error if action failed + if ($rc) { + print STDERR $this, ' ', $function, ' failed (', $rc, ')', "\n"; + exit 1; + + } else { + exit; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &compile (\%info); +# +# DESCRIPTION +# This method invokes the correct compiler with the correct options to +# compile the source file into the required target. The argument $info is a +# hash reference set up in MAIN. The following environment variables are +# used, where * is the source file type (F for Fortran, and C for C/C++): +# +# *C - compiler command +# *C_OUTPUT - *C option to specify the name of the output file +# *C_DEFINE - *C option to declare a pre-processor def +# *C_INCLUDE - *C option to declare an include directory +# *C_MODSEARCH- *C option to declare a module search directory +# *C_COMPILE - *C option to ask the compiler to perform compile only +# *CFLAGS - *C user options +# *PPKEYS - list of pre-processor defs (may have sub-package suffix) +# FCM_VERBOSE - verbose level +# FCM_OBJDIR - destination directory of object file +# FCM_TMPDIR - temporary destination directory of object file +# ------------------------------------------------------------------------------ + +sub compile { + my $info = shift; + + # Verbose mode + my $verbose = &get_env ('FCM_VERBOSE'); + $verbose = 1 unless defined ($verbose); + + my @command = (); + + # Guess file type for backward compatibility + my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC}); + + # Compiler + push @command, &get_env ($type . 'C', 1); + + # Compile output target (typical -o option) + push @command, &get_env ($type . 'C_OUTPUT', 1), $info->{TARGET}; + + # Pre-processor definition macros + if ($info->{REQUIREPP}) { + my @ppkeys = split /\s+/, &select_flags ($info, $type . 'PPKEYS'); + my $defopt = &get_env ($type . 'C_DEFINE', 1); + + push @command, (map {$defopt . $_} @ppkeys); + } + + # Include search path + my $incopt = &get_env ($type . 'C_INCLUDE', 1); + my @incpath = split /:/, &get_env ('FCM_INCPATH'); + push @command, (map {$incopt . $_} @incpath); + + # Compiled module search path + my $modopt = &get_env ($type . 'C_MODSEARCH'); + if ($modopt) { + push @command, (map {$modopt . $_} @incpath); + } + + # Other compiler flags + my $flags = &select_flags ($info, $type . 'FLAGS'); + push @command, $flags if $flags; + + my $compile_only = &get_env ($type . 'C_COMPILE'); + if ($flags !~ /(?:^|\s)$compile_only\b/) { + push @command, &get_env ($type . 'C_COMPILE'); + } + + # Name of source file + push @command, $info->{SRC}; + + # Execute command + my $objdir = &get_env ('FCM_OBJDIR', 1); + my $tmpdir = &get_env ('FCM_TMPDIR', 1); + chdir $tmpdir; + + my $command = join ' ', @command; + if ($verbose > 1) { + print 'cd ', $tmpdir, "\n"; + print ×tamp_command ($command, 'Start'); + + } elsif ($verbose) { + print $command, "\n"; + } + + my $rc = system $command; + + print ×tamp_command ($command, 'End ') if $verbose > 1; + + # Move temporary output to correct location on success + # Otherwise, remove temporary output + if ($rc) { # error + unlink $info->{TARGET}; + + } else { # success + print 'mv ', $info->{TARGET}, ' ', $objdir, "\n" if $verbose > 1; + rename $info->{TARGET}, &catfile ($objdir, $info->{TARGET}); + } + + # Move any Fortran module definition files to the INC directory + my @modfiles = <*.mod *.MOD>; + for my $file (@modfiles) { + rename $file, &catfile ($incpath[0], $file); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &load (\%info); +# +# DESCRIPTION +# This method invokes the correct loader with the correct options to link +# the main program object into an executable. The argument $info is a hash +# reference set up in MAIN. The following environment variables are used: +# +# LD - * linker command +# LD_OUTPUT - LD option to specify the name of the output file +# LD_LIBSEARCH - LD option to declare a directory in the library search path +# LD_LIBLINK - LD option to declare an object library +# LDFLAGS - LD user options +# FCM_VERBOSE - verbose level +# FCM_LIBDIR - destination directory of object libraries +# FCM_OBJDIR - destination directory of object files +# FCM_BINDIR - destination directory of executable file +# FCM_TMPDIR - temporary destination directory of executable file +# +# * If LD is not set, it will attempt to guess the file type and use the +# compiler as the linker. +# ------------------------------------------------------------------------------ + +sub load { + my $info = shift; + + my $rc = 0; + + # Verbose mode + my $verbose = &get_env ('FCM_VERBOSE'); + $verbose = 1 unless defined ($verbose); + + # Create temporary object library + (my $name = $info->{TARGET}) =~ s/\.\S+$//; + my $libname = '__fcm__' . $name; + my $lib = 'lib' . $libname . '.a'; + my $libfile = catfile (&get_env ('FCM_LIBDIR', 1), $lib); + $rc = &archive ({TARGET => $lib}); + + unless ($rc) { + my @command = (); + + # Linker + my $ld = &select_flags ($info, 'LD'); + if (not $ld) { + # Guess file type for backward compatibility + my $type = $info->{TYPE} ? $info->{TYPE} : &guess_file_type ($info->{SRC}); + $ld = &get_env ($type . 'C', 1); + } + push @command, $ld; + + # Linker output target (typical -o option) + push @command, &get_env ('LD_OUTPUT', 1), $info->{TARGET}; + + # Name of main object file + my $mainobj = (basename ($info->{SRC}) eq $info->{SRC}) + ? catfile (&get_env ('FCM_OBJDIR'), $info->{SRC}) + : $info->{SRC}; + push @command, $mainobj; + + # Link with Fortran BLOCKDATA objects if necessary + if (@{ $info->{BLOCKDATA} }) { + my @blockdata = @{ $info->{BLOCKDATA} }; + my @objpath = split /:/, &get_env ('FCM_OBJPATH'); + + # Search each BLOCKDATA object file from the object search path + for my $file (@blockdata) { + for my $dir (@objpath) { + my $full = catfile ($dir, $file); + + if (-r $full) { + $file = $full; + last; + } + } + + push @command, $file; + } + } + + # Library search path + my $libopt = &get_env ('LD_LIBSEARCH', 1); + my @libpath = split /:/, &get_env ('FCM_LIBPATH'); + push @command, (map {$libopt . $_} @libpath); + + # Link with temporary object library if it exists + push @command, &get_env ('LD_LIBLINK', 1) . $libname if -f $libfile; + + # Other linker flags + my $flags = &select_flags ($info, 'LDFLAGS'); + push @command, $flags; + + # Execute command + my $tmpdir = &get_env ('FCM_TMPDIR', 1); + my $bindir = &get_env ('FCM_BINDIR', 1); + chdir $tmpdir; + + my $command = join ' ', @command; + if ($verbose > 1) { + print 'cd ', $tmpdir, "\n"; + print ×tamp_command ($command, 'Start'); + + } elsif ($verbose) { + print $command, "\n"; + } + + $rc = system $command; + + print ×tamp_command ($command, 'End ') if $verbose > 1; + + # Move temporary output to correct location on success + # Otherwise, remove temporary output + if ($rc) { # error + unlink $info->{TARGET}; + + } else { # success + print 'mv ', $info->{TARGET}, ' ', $bindir, "\n" if $verbose > 1; + rename $info->{TARGET}, &catfile ($bindir, $info->{TARGET}); + } + } + + # Remove the temporary object library + unlink $libfile if -f $libfile; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &archive (\%info); +# +# DESCRIPTION +# This method invokes the library archiver to create an object library. The +# argument $info is a hash reference set up in MAIN. The following +# environment variables are used: +# +# AR - archiver command +# ARFLAGS - AR options to update/create an object library +# FCM_VERBOSE - verbose level +# FCM_LIBDIR - destination directory of object libraries +# FCM_OBJPATH - search path of object files +# FCM_OBJDIR - destination directory of object files +# FCM_TMPDIR - temporary destination directory of executable file +# ------------------------------------------------------------------------------ + +sub archive { + my $info = shift; + + my $rc = 0; + + # Verbose mode + my $verbose = &get_env ('FCM_VERBOSE'); + $verbose = 1 unless defined ($verbose); + + # Set up the archive command + my $lib = &basename ($info->{TARGET}); + my $tmplib = &catfile (&get_env ('FCM_TMPDIR', 1), $lib); + my @ar_cmd = (); + push @ar_cmd, (&get_env ('AR', 1), &get_env ('ARFLAGS', 1)); + push @ar_cmd, $tmplib; + + # Get object directories and their files + my %objdir; + if (exists $info->{OBJECTS}) { + # List of objects set in the argument, sort into directory/file list + for my $name (@{ $info->{OBJECTS} }) { + my $dir = (&dirname ($name) eq '.') + ? &get_env ('FCM_OBJDIR', 1) : &dirname ($name); + $objdir{$dir}{&basename ($name)} = 1; + } + + } else { + # Objects not listed in argument, search object path for all files + my @objpath = split /:/, &get_env ('FCM_OBJPATH', 1); + my %objbase = (); + + # Get registered objects into a hash (keys = objects, values = 1) + my %objects = map {($_, 1)} split (/\s+/, &get_env ('OBJECTS')); + + # Seach object path for all files + for my $dir (@objpath) { + next unless -d $dir; + + chdir $dir; + + # Use all files from each directory in the object search path + for ((glob ('*'))) { + next unless exists $objects{$_}; # consider registered objects only + $objdir{$dir}{$_} = 1 unless exists $objbase{$_}; + $objbase{$_} = 1; + } + } + } + + for my $dir (sort keys %objdir) { + next unless -d $dir; + + # Go to each object directory and executes the library archive command + chdir $dir; + my $command = join ' ', (@ar_cmd, sort keys %{ $objdir{$dir} }); + + if ($verbose > 1) { + print 'cd ', $dir, "\n"; + print ×tamp_command ($command, 'Start'); + + } else { + print $command, "\n" if exists $info->{OBJECTS}; + } + + $rc = system $command; + + print ×tamp_command ($command, 'End ') + if $verbose > 1; + last if $rc; + } + + # Move temporary output to correct location on success + # Otherwise, remove temporary output + if ($rc) { # error + unlink $tmplib; + + } else { # success + my $libdir = &get_env ('FCM_LIBDIR', 1); + + print 'mv ', $tmplib, ' ', $libdir, "\n" if $verbose > 1; + rename $tmplib, &catfile ($libdir, $lib); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $type = &guess_file_type ($filename); +# +# DESCRIPTION +# This function attempts to guess the file type by looking at the extension +# of the $filename. Only C and Fortran at the moment. +# ------------------------------------------------------------------------------ + +sub guess_file_type { + return (($_[0] =~ /\.c(\w+)?$/i) ? 'C' : 'F'); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flags = &select_flags (\%info, $set); +# +# DESCRIPTION +# This function selects the correct compiler/linker flags for the current +# sub-package from the environment variable prefix $set. The argument $info +# is a hash reference set up in MAIN. +# ------------------------------------------------------------------------------ + +sub select_flags { + my ($info, $set) = @_; + + my $srcbase = &basename ($info->{SRC}); + my @names = ($set); + push @names, split (/__/, $info->{SRCPACKAGE} . '__' . $srcbase); + + my $string = ''; + for my $i (reverse (0 .. $#names)) { + my $var = &get_env (join ('__', (@names[0 .. $i]))); + + $var = &get_env (join ('__', (@names[0 .. $i]))) + if (not defined ($var)) and $i and $names[-1] =~ s/\.[^\.]+$//; + + next unless defined $var; + $string = $var; + last; + } + + return $string; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $variable = &get_env ($name); +# $variable = &get_env ($name, $compulsory); +# +# DESCRIPTION +# This internal method gets a variable from $ENV{$name}. If $compulsory is +# set to true, it throws an error if the variable is a not set or is an empty +# string. Otherwise, it returns C if the variable is not set. +# ------------------------------------------------------------------------------ + +sub get_env { + (my $name, my $compulsory) = @_; + my $string; + + if ($name =~ /^\w+$/) { + # $name contains only word characters, variable is exported normally + die 'The environment variable "', $name, '" must be set, abort' + if $compulsory and not exists $ENV{$name}; + + $string = exists $ENV{$name} ? $ENV{$name} : undef; + + } else { + # $name contains unusual characters + die 'The environment variable "', $name, '" must be set, abort' + if $compulsory and not exists $unusual_tool_name{$name}; + + $string = exists $unusual_tool_name{$name} + ? $unusual_tool_name{$name} : undef; + } + + return $string; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = &catfile (@paths); +# +# DESCRIPTION +# This is a local implementation of what is in the File::Spec module. +# ------------------------------------------------------------------------------ + +sub catfile { + my @names = split (m!/!, join ('/', @_)); + my $path = shift @names; + + for my $name (@names) { + $path .= '/' . $name if $name; + } + + return $path; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $basename = &basename ($path); +# +# DESCRIPTION +# This is a local implementation of what is in the File::Basename module. +# ------------------------------------------------------------------------------ + +sub basename { + my $name = $_[0]; + + $name =~ s{/*$}{}; # remove trailing slashes + + if ($name =~ m#.*/([^/]+)$#) { + return $1; + + } else { + return $name; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $dirname = &dirname ($path); +# +# DESCRIPTION +# This is a local implementation of what is in the File::Basename module. +# ------------------------------------------------------------------------------ + +sub dirname { + my $name = $_[0]; + + if ($name =~ m#^/+$#) { + return '/'; # dirname of root is root + + } else { + $name =~ s{/*$}{}; # remove trailing slashes + + if ($name =~ m#^(.*)/[^/]+$#) { + my $dir = $1; + $dir =~ s{/*$}{}; # remove trailing slashes + return $dir; + + } else { + return '.'; + } + } +} + +# ------------------------------------------------------------------------------ + +__END__ + +=head1 NAME + +fcm_internal + +=head1 SYNOPSIS + + fcm_internal SUBCOMMAND ARGS + +=head1 DESCRIPTION + +The fcm_internal command is a frontend for some of the internal commands of +the FCM build system. The subcommand can be "compile", "load" or "archive" +for invoking the compiler, loader and library archiver respectively. If +"compile" or "load" is specified, it can be suffixed with ":TYPE" to +specify the nature of the source file. If TYPE is not specified, it is set +to C if the file extension begins with ".c". For all other file types, it +is set to F (for Fortran source). For compile and load, the other arguments +are 1) the name of the container package of the source file, 2) the path to +the source file and 3) the target name after compiling or loading the +source file. For compile, the 4th argument is a flag to indicate whether +pre-processing is required for compiling the source file. For load, the +4th and the rest of the arguments is a list of object files that cannot be +archived into the temporary load library and must be linked into the target +through the linker command. (E.g. Fortran BLOCKDATA program units must be +linked this way.) If archive is specified, the first argument should be the +name of the library archive target and the rest should be the object files +to be included in the archive. This command is invoked via the build system +and should never be called directly by the user. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm_setup_konqueror b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_setup_konqueror new file mode 100755 index 0000000..576022f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_setup_konqueror @@ -0,0 +1,47 @@ +#!/bin/sh +# ------------------------------------------------------------------------------ +# NAME +# fcm_setup_konqueror +# +# SYNOPSIS +# fcm_setup_konqueror +# +# DESCRIPTION +# Set up Konqueror to use "fcm gui". +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +# Check number of arguments +script=`basename $0` +usage="$script: no argument required" +if (( $# != 0 )); then + echo "$usage, abort..." >&2 + exit 1 +fi + +filename=fcm_gui.desktop + +file=`dirname $0` +if [[ `basename $file` = bin ]]; then + file=`dirname $file` +fi +file=$file/etc/$filename + +if [[ ! -f $file ]]; then + echo "$script: $file not found, abort..." >&2 + exit 1 +fi + +dir=$HOME/.kde/share/applnk/.hidden +mkdir -p $dir +cd $dir +rm -f $filename # Always remove. +ln -s $file . + +echo "$script: finished" + +#EOF diff --git a/NEMO_4.0.4_surge/ext/FCM/bin/fcm_update_version_dir.pl b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_update_version_dir.pl new file mode 100755 index 0000000..4904295 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/bin/fcm_update_version_dir.pl @@ -0,0 +1,289 @@ +#!/usr/bin/env perl +#------------------------------------------------------------------------------- +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +#------------------------------------------------------------------------------- + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Cwd qw{cwd}; +use Getopt::Long qw{GetOptions}; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Util qw{get_url_of_wc get_wct is_wc run_command tidy_url}; +use File::Basename qw{basename dirname}; +use File::Path qw{mkpath}; +use File::Spec; +use Pod::Usage qw{pod2usage}; + +# Usage +# ------------------------------------------------------------------------------ +my $this = basename($0); + +# Options +# ------------------------------------------------------------------------------ +my ($dest, $full, $help, $url); +my $rc = GetOptions( + 'dest|d=s' => \$dest, + 'full|f' => \$full, + 'help' => \$help, + 'url|u=s' => \$url, +); +if (!$rc) { + pod2usage({'-verbose' => 1}); +} +if ($help) { + pod2usage({'-exitval' => 0, '-verbose' => 1}); +} +if (!$url) { + pod2usage( + {'-message' => 'The --url=URL option is compulsory', '-verbose' => 1}, + ); +} +$dest ||= cwd(); + +# Arguments +# ------------------------------------------------------------------------------ +if (@ARGV) { + die 'Cannot read: ', $ARGV[0], ', abort' unless -f $ARGV[0] and -r $ARGV[0]; +} + +# Get configuration settings +# ------------------------------------------------------------------------------ +my $config = Fcm::Config->new (); +$config->get_config (); + +# Expand URL keyword +$url = Fcm::Util::tidy_url(Fcm::Keyword::expand($url)); + +# ------------------------------------------------------------------------------ + +MAIN: { + my $date = localtime; + print $this, ': started on ', $date, "\n"; + + my %dirs; + + # Read input (file) for a list directories and update conditions + while (<>) { + chomp; + + # Ignore empty and comment lines + next if /^\s*(?:#|$)/; + + # Each line must contain a relative path, and optionally a list of + # space delimited conditions + my @words = split /\s+/; + my $dir = shift @words; + + # Check that the conditions are valid + my @conditions; + for my $word (@words) { + if ($word =~ /^([<>]=?|[!=]=)(.+)$/i) { + # Condition must be a conditional operator followed by a revision + my ($operator, $rev) = ($1, $2); + $rev = (Fcm::Keyword::expand($url, $rev))[1]; + push @conditions, $operator . $rev; + + } else { + print STDERR 'Warning: ignore unknown syntax for update condition: ', + $word, "\n"; + } + } + + # Add directory and its conditions to a hash + if ($dir =~ s#/\*$##) { # Directory finishes with wildcard + + # Run "svn ls" in recursive mode + my $dirurl = join ('/', ($url, $dir)); + my @files = &run_command ([qw/svn ls -R/, $dirurl], METHOD => 'qx'); + + # Find directories containing regular files + while (my $file = shift @files) { + # Skip directories + next if $file =~ m#/$#; + + # Get "dirname" of regular file and add to hash + my $subdir = join ('/', ($dir, dirname ($file))); + $dirs{$subdir} = \@conditions; + } + + } else { + $dirs{$dir} = \@conditions; + } + + } + + # Update each directory, if required + for my $dir (sort keys %dirs) { + # Use "svn log" to determine the revisions that need to be updated + my %allversions; + { + my $command = 'svn log -q ' . join ('/', ($url, $dir)); + my @log = &run_command ( + [qw/svn log -q/, join ('/', ($url, $dir))], METHOD => 'qx', + ); + @log = grep /^r\d+/, @log; + + # Assign a sequential "version" number to each sub-directory + my $version = scalar @log; + for (@log) { + m/^r(\d+)/; + $allversions{$1} = 'v' . $version--; + } + } + my %versions = %allversions; + + # Extract only revisions matching the conditions + if (@{ $dirs{$dir} }) { + my @conditions = @{ $dirs{$dir} }; + + for my $condition (@conditions) { + for my $rev (keys %versions) { + delete $versions{$rev} unless eval ($rev . $condition); + } + } + } + + # Destination directory + my $dirpath = File::Spec->catfile ($dest, $dir); + + if (-d $dirpath) { + if ($full or not keys %versions) { + # Remove destination directory top, in full mode + # or if there are no matching revisions + &run_command ([qw/rm -rf/, $dirpath], PRINT => 1); + + } else { + # Delete excluded revisions if they exist, in incremental mode + if (opendir DIR, $dirpath) { + while (my $rev = readdir 'DIR') { + next unless $rev =~ /^\d+$/; + + if (not grep {$_ eq $rev} keys %versions) { + my @command = (qw/rm -rf/, File::Spec->catfile ($dirpath, $rev)); + &run_command (\@command, PRINT => 1); + + # Remove "version" symlink + my $verlink = File::Spec->catfile ($dirpath, $allversions{$rev}); + unlink $verlink if -l $verlink; + } + } + closedir DIR; + } + } + } + + # Create container directory of destination if it does not already exist + if (keys %versions and not -d $dirpath) { + print '-> mkdir -p ', $dirpath, "\n"; + my $rc = mkpath $dirpath; + die 'mkdir -p ', $dirpath, ' failed' unless $rc; + } + + # Update each version directory that needs updating + for my $rev (keys %versions) { + my $revpath = File::Spec->catfile ($dest, $dir, $rev); + + # Create version directory if it does not exist + if (not -e $revpath) { + # Use "svn export" to create the version directory + my @command = ( + qw/svn export -q -r/, + $rev, + join ('/', ($url, $dir)), + $revpath, + ); + + &run_command (\@command, PRINT => 1); + } + + # Create "version" symlink if necessary + my $verlink = File::Spec->catfile ($dest, $dir, $versions{$rev}); + symlink $rev, $verlink unless -l $verlink; + } + + # Symbolic link to the "latest" version directory + my $headlink = File::Spec->catfile ($dest, $dir, 'latest'); + my $headrev = 0; + for my $rev (keys %versions) { + $headrev = $rev if $rev > $headrev; + } + + if (-l $headlink) { + # Remove old symbolic link if there is no revision to update or if it + # does not point to the correct version directory + my $org = readlink $headlink; + unlink $headlink if (! $headrev or $org ne $headrev); + } + + # (Re-)create the "latest" symbolic link, if necessary + symlink $headrev, $headlink if ($headrev and not -l $headlink); + } + + $date = localtime; + print $this, ': finished normally on ', $date, "\n"; +} + +__END__ + +=head1 NAME + +fcm_update_version_dir.pl + +=head1 SYNOPSIS + + fcm_update_version_dir.pl [OPTIONS] [CFGFILE] + +=head1 DESCRIPTION + +Update the version directories for a list of relative paths in the source +repository URL. + +=head1 OPTIONS + +=over 4 + +=item --dest=DEST, -d DEST + +Specify a destination for the extraction. If not specified, the command extracts +to the current working directory. + +=item --help, -h + +Print help and exit. + +=item --full, -f + +Specify the full mode. If not specified, the command runs in incremental mode. + +=item --url=URL, -u URL + +Specify the source repository URL. No default. + +=back + +=head1 ARGUMENTS + +A configuration file may be given to this command, or it will attempt to read +from the standard input. Each line in the configuration must contain a relative +path that resides under the given source repository URL. (Empty lines and lines +beginning with a "#" are ignored.) Optionally, each relative path may be +followed by a list of space separated "conditions". Each condition is a +conditional operator (>, >=, <, <=, == or !=) followed by a revision number or +the keyword HEAD. The command uses the revision log to determine the revisions +at which the relative path has been updated in the source repository URL. If +these revisions also satisfy the "conditions" set by the user, they will be +considered in the extraction. In full mode, everything is re-extracted. In +incremental mode, the version directories are only updated if they do not +already exist. + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/etc/fcm.cfg.eg b/NEMO_4.0.4_surge/ext/FCM/etc/fcm.cfg.eg new file mode 100644 index 0000000..955091f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/etc/fcm.cfg.eg @@ -0,0 +1,266 @@ +# ------------------------------------------------------------------------------ +# FCM central configuration file +# ------------------------------------------------------------------------------ + +# ------------------------------------------------------------------------------ +# Standard repository locations +# ------------------------------------------------------------------------------ + +# 3dVOM repository +set::url::3dvom svn://fcm9/3dVOM_svn/3dVOM + +# AAPP repository +set::url::aapp svn://fcm7/AAPP_svn/AAPP + +# AMV repository +set::url::amv svn://fcm7/AMV_svn/AMV + +# ANCIL repository +set::url::ancil svn://fcm8/ANCIL_svn/ANCIL + +# ATSR repository +set::url::atsr svn://fcm7/ATSR_svn/ATSR + +# BLASIUS repository +set::url::blasius svn://fcm2/BLASIUS_svn/BLASIUS + +# CICE repository +set::url::cice svn://fcm3/CICE_svn/CICE + +# CMA repository +set::url::cma svn://fcm9/CMA_svn/CMA + +# CVC repository +set::url::cvc_admin svn://fcm6/CVC_svn/Admin +set::url::bufr svn://fcm6/CVC_svn/BUFR +set::url::bullseye svn://fcm6/CVC_svn/Bullseye +set::url::cat svn://fcm6/CVC_svn/CAT +set::url::deicing svn://fcm6/CVC_svn/Deicing +set::url::ea svn://fcm6/CVC_svn/EA +set::url::ensemble svn://fcm6/CVC_svn/Ensemble +set::url::gales svn://fcm6/CVC_svn/Gales +set::url::ifv svn://fcm6/CVC_svn/IFV +set::url::mogreps svn://fcm6/CVC_svn/MOGREPS +set::url::openroad svn://fcm6/CVC_svn/OpenRoad +set::url::powertable svn://fcm6/CVC_svn/PowerTable +set::url::qnh svn://fcm6/CVC_svn/QNH +set::url::tafs svn://fcm6/CVC_svn/TAFS +set::url::warnings svn://fcm6/CVC_svn/WARNINGS + +# DA repository +set::url::da svn://fcm5/DA_svn/DA + +# ENS repository +set::url::ens svn://fcm9/ENS_svn/ENS + +# ERSEM repository +set::url::ersem svn://fcm3/ERSEM_svn/ERSEM +set::url::ersem_pml svn://fcm3/ERSEM_svn/ERSEM_PML + +# FCM repository +set::url::fcm svn://fcm1/FCM_svn/FCM +set::url::fcm_admin svn://fcm1/FCM_svn/Admin + + +# FLUME repository +set::url::flume_metadata svn://fcm2/FLUME_svn/metadata +set::url::flume_framework svn://fcm2/FLUME_svn/framework +set::url::flume_models svn://fcm2/FLUME_svn/models +set::url::flume_jobs svn://fcm2/FLUME_svn/jobs + +# FORMOST repository +set::url::formost_local svn://fcm9/FORMOST_svn/FORMOST_LOCAL +set::url::formost_remote svn://fcm9/FORMOST_svn/FORMOST_REMOTE + +# GEN repository +set::url::gen svn://fcm1/GEN_svn/GEN + +# GS repository +set::url::gs svn://fcm9/GS_svn/GS + +# HadGOA repository +set::url::hadgoa svn://fcm9/HadGOA_svn/HadGOA + +# HadISD repository +set::url::hadisd_gen svn://fcm9/HadISD_svn/general +set::url::hadisd_homog svn://fcm9/HadISD_svn/homogenisation +set::url::hadisd_qc svn://fcm9/HadISD_svn/quality_control + +# IRIS repository +set::url::iris svn://fcm9/IRIS_svn/IRIS + +# LEM repository +set::url::lem svn://fcm2/LEM_svn/LEM + +# LINK repository +set::url::link svn://fcm1/LINK_svn/LINK + +# MASS_MIG repository +set::url::mass_mig svn://fcm9/MASS_MIG_svn/MASS_MIG + +# MOOSE repository +set::url::moose svn://fcm9/MOOSE_svn/MOOSE + +# MOSIG repository +set::url::mosig svn://fcm9/MOSIG_svn/MOSIG + +# MUMTI repository +set::url::mumti svn://fcm1/MUMTI_svn/Project + +# NEMO repository +set::url::nemosys svn://fcm3/NEMO_svn/NEMOSYS +set::url::nemovar svn://fcm3/NEMO_svn/NEMOVAR +set::url::nemo svn://fcm3/NEMO_svn/NEMO +set::url::ioipsl svn://fcm3/NEMO_svn/IOIPSL +set::url::ocnasm svn://fcm3/NEMO_svn/OCNASM +set::url::nemoukmo svn://fcm3/NEMO_svn/UKMO + +# NWPSAF repository + +set::url::meto_1dvar svn://fcm7/NWPSAF_svn/MetOffice_1DVar +set::url::ssmis_1dvar svn://fcm7/NWPSAF_svn/ssmis_1DVar +set::url::ssmis_pp svn://fcm7/NWPSAF_svn/ssmis_PP + +# NWPWEB repository +set::url::www_nwp svn://fcm1/NWPWEB_svn/www_nwp + +# obsmon repository +set::url::obsmon_dc svn://fcm4/obsmon_svn/DC +set::url::obsmon_rtm svn://fcm4/obsmon_svn/RTM + +# ODB repository +set::url::odb svn://fcm4/ODB_svn/ODB + +# OCN repository +set::url::polcoms svn://fcm3/OCN_svn/POLCOMS + +# OPFC repository +set::url::opfc svn://fcm9/OPFC_svn/OPFC + +# OPS repository +set::url::ops svn://fcm4/OPS_svn/OPS +set::url::ops_admin svn://fcm4/OPS_svn/Admin +set::url::ops_data svn://fcm4/OPS_svn/Data +set::url::ops_external svn://fcm4/OPS_svn/External + +# OSTIA repository +set::url::ostia svn://fcm3/OSTIA_svn/OSTIA + +# PF repository +set::url::pf svn://fcm5/PF_svn/PF + +# PostProc repository +set::url::pp svn://fcm9/PostProc_svn/PostProc +set::url::ppancil svn://fcm9/PostProc_svn/PostProcAncil +set::url::ppvssps svn://fcm9/PostProc_svn/VerificationSSPS + +# PRISM repository +set::url::oasis3 svn://fcm2/PRISM_svn/OASIS3 +set::url::oasis4 svn://fcm2/PRISM_svn/OASIS4 +set::url::prism_ukmo svn://fcm2/PRISM_svn/PRISM_UKMO + +# radarnet repository +set::url::radarnet4 svn://fcm9/radarnet_svn/radarnet4 + +# RADSAT repository +set::url::polar svn://fcm7/RADSAT_svn/POLAR +set::url::radsat svn://fcm7/RADSAT_svn/RADSAT + +# ROPP repository +set::url::ropp_doc svn://fcm7/ROPP_svn/ropp_doc +set::url::ropp_src svn://fcm7/ROPP_svn/ropp_src +set::url::ropp_test svn://fcm7/ROPP_svn/ropp_test +set::url::ropp_web svn://fcm7/ROPP_svn/ropp_web + +# RTTOV repository +set::url::rttov svn://fcm7/RTTOV_svn/RTTOV +set::url::rttov8 svn://fcm7/RTTOV_svn/RTTOV8 +set::url::rttov9 svn://fcm7/RTTOV_svn/RTTOV9 + +# SAUtils repository +set::url::autoscat_global svn://fcm7/SAUtils_svn/AUTOSCAT_Global +set::url::autoscat_nae svn://fcm7/SAUtils_svn/AUTOSCAT_NAE +set::url::climetop svn://fcm7/SAUtils_svn/CLIMETOP +set::url::dataflow svn://fcm7/SAUtils_svn/DataFlow +set::url::gpsiwv_mon svn://fcm7/SAUtils_svn/GPSIWV_Mon +set::url::gpswv_nrt svn://fcm7/SAUtils_svn/GPSWV_NRT +set::url::gpsro_mon svn://fcm7/SAUtils_svn/GPSRO_Mon +set::url::iasi_mon svn://fcm7/SAUtils_svn/IASI_Mon +set::url::metstrike svn://fcm7/SAUtils_svn/METSTRIKE +set::url::scatwind_mon svn://fcm7/SAUtils_svn/Scatwind_Mon + +# SBV repository +set::url::sbv svn://fcm6/SBV_svn/SBV +set::url::sbv_admin svn://fcm6/SBV_svn/Admin + +# SCS repository +set::url::scs svn://fcm1/SCS_svn/SCS +set::url::scs_admin svn://fcm1/SCS_svn/Admin +set::url::tik svn://fcm1/SCS_svn/TIK +set::url::tt svn://fcm1/SCS_svn/TT + +# SPS repository +set::url::sps svn://fcm7/SPS_svn/SPS +set::url::tigger svn://fcm7/SPS_svn/Tigger +set::url::sps_archive svn://fcm7/SPS_svn/Archive + +# SURF repository +set::url::surf svn://fcm8/SURF_svn/SURF + +# SWARV repository +set::url::swarv svn://fcm9/SWARV_svn/SWARV + +# test repository +set::url::test svn://fcm1/test_svn/OPS + +# tutorial repository +set::url::tutorial svn://fcm1/tutorial_svn/tutorial + +# THORPEX repository +set::url::thorpex svn://fcm9/ENS_svn/ENS + +# TRUI repository +set::url::trui svn://fcm1/TRUI_svn/TRUI + +# UM repository +set::url::um svn://fcm2/UM_svn/UM +set::url::um_admin svn://fcm2/UM_svn/Admin +set::url::gcom svn://fcm2/UM_svn/GCOM + +# UM tutorial repository +set::url::um_tutorial svn://fcm2/UM_TUTORIAL_svn/UM + +# utils repository +set::url::app_publications svn://fcm9/utils_svn/APP_publications +set::url::asyncios svn://fcm9/utils_svn/asyncIOS +set::url::avapps_coldsoak svn://fcm9/utils_svn/avapps_coldsoak +set::url::avapps_verCB svn://fcm9/utils_svn/avapps_verCB +set::url::crmtest svn://fcm9/utils_svn/cr_model_testing +set::url::cr_valnote svn://fcm9/utils_svn/cr_validation_note +set::url::fray_utils svn://fcm9/utils_svn/fray_utils +set::url::hpss_tests svn://fcm9/utils_svn/HPSS_tests +set::url::jules_benchmarking svn://fcm9/utils_svn/jules_benchmarking +set::url::jules_standalone svn://fcm9/utils_svn/jules_standalone +set::url::kid svn://fcm9/utils_svn/KiD +set::url::numerical_methods svn://fcm9/utils_svn/numerical_methods +set::url::wavefc svn://fcm9/utils_svn/wave_forecasting + +# VAR repository +set::url::var svn://fcm5/VAR_svn/VAR +set::url::var_admin svn://fcm5/VAR_svn/Admin +set::url::var_data svn://fcm5/VAR_svn/Data + +# VER repository +set::url::ver svn://fcm6/VER_svn/VER +set::url::ver_admin svn://fcm6/VER_svn/Admin +set::url::ver_archive svn://fcm6/VER_svn/Archive + +# VMM repository +set::url::vmm svn://fcm9/VMM_svn/VMM + +# WW3 repository +set::url::ww3 svn://fcm3/WW3_svn/WW3 +set::url::ww3_config svn://fcm3/WW3_svn/WW3CONFIG +set::url::ww3_utils svn://fcm3/WW3_svn/WW3UTILS + +# EOF diff --git a/NEMO_4.0.4_surge/ext/FCM/etc/fcm_gui.desktop b/NEMO_4.0.4_surge/ext/FCM/etc/fcm_gui.desktop new file mode 100644 index 0000000..69bf5fd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/etc/fcm_gui.desktop @@ -0,0 +1,13 @@ +[Desktop Entry] +Comment= +Exec=fcm gui %f +Hidden=false +Icon=wizard +MimeType=inode/directory +Name=FCM GUI +Path= +Terminal=0 +TerminalOptions= +Type=Application +X-KDE-SubstituteUID=false +X-KDE-Username= diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Base.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Base.pm new file mode 100644 index 0000000..350e3aa --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Base.pm @@ -0,0 +1,112 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Base +# +# DESCRIPTION +# This is base class for all FCM OO packages. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Base; + +# Standard pragma +use strict; +use warnings; + +use Fcm::Config; + +my @scalar_properties = ( + 'config', # instance of Fcm::Config, configuration setting +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Base->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Base class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = {}; + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'config') { + # Configuration setting of the main program + $self->{$name} = Fcm::Config->instance(); + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $self->setting (@args); # $self->config->setting +# $value = $self->verbose (@args); # $self->config->verbose +# ------------------------------------------------------------------------------ + +for my $name (qw/setting verbose/) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + return $self->config->$name (@_); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $self->cfglabel (@args); +# +# DESCRIPTION +# This is an alias to $self->config->setting ('CFG_LABEL', @args); +# ------------------------------------------------------------------------------ + +sub cfglabel { + my $self = shift; + return $self->setting ('CFG_LABEL', @_); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Build.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Build.pm new file mode 100644 index 0000000..41da76b --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Build.pm @@ -0,0 +1,1606 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Build +# +# DESCRIPTION +# This is the top level class for the FCM build system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +package Fcm::Build; +use base qw(Fcm::ConfigSystem); + +use Carp qw{croak} ; +use Cwd qw{cwd} ; +use Fcm::BuildSrc ; +use Fcm::BuildTask ; +use Fcm::Config ; +use Fcm::Dest ; +use Fcm::CfgLine ; +use Fcm::Timer qw{timestamp_command} ; +use Fcm::Util qw{expand_tilde run_command touch_file w_report}; +use File::Basename qw{dirname} ; +use File::Spec ; +use List::Util qw{first} ; +use Text::ParseWords qw{shellwords} ; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'name', # name of this build + 'target', # targets of this build +); + +# List of hash property methods for this class +my @hash_properties = ( + 'srcpkg', # source packages of this build + 'dummysrcpkg', # dummy for handling package inheritance with file extension +); + +# List of compare_setting_X methods +my @compare_setting_methods = ( + 'compare_setting_bld_blockdata', # program executable blockdata dependency + 'compare_setting_bld_dep', # custom dependency setting + 'compare_setting_bld_dep_excl', # exclude dependency setting + 'compare_setting_bld_dep_n', # no dependency check + 'compare_setting_bld_dep_pp', # custom PP dependency setting + 'compare_setting_bld_dep_exe', # program executable extra dependency + 'compare_setting_bld_exe_name', # program executable rename + 'compare_setting_bld_pp', # PP flags + 'compare_setting_infile_ext', # input file extension + 'compare_setting_outfile_ext', # output file extension + 'compare_setting_tool', # build tool settings +); + +my $DELIMITER_LIST = $Fcm::Config::DELIMITER_LIST; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Build->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Build class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::ConfigSystem->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + $self->{$_} = {} for (@hash_properties); + + bless $self, $class; + + # List of sub-methods for parse_cfg + push @{ $self->cfg_methods }, (qw/target source tool dep misc/); + + # Optional prefix in configuration declaration + $self->cfg_prefix ($self->setting (qw/CFG_LABEL BDECLARE/)); + + # System type + $self->type ('bld'); + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'target') { + # Reference to an array + $self->{$name} = []; + + } elsif ($name eq 'name') { + # Empty string + $self->{$name} = ''; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->X ($old_lines); +# +# DESCRIPTION +# This method compares current settings with those in the cache, where X is +# one of @compare_setting_methods. +# +# If setting has changed: +# * For bld_blockdata, bld_dep_ext and bld_exe_name, it sets the re-generate +# make-rule flag to true. +# * For bld_dep_excl, in a standalone build, the method will remove the +# dependency cache files for affected sub-packages. It returns an error if +# the current build inherits from previous builds. +# * For bld_pp, it updates the PP setting for affected sub-packages. +# * For infile_ext, in a standalone build, the method will remove all the +# sub-package cache files and trigger a re-build by removing most +# sub-directories created by the previous build. It returns an error if the +# current build inherits from previous builds. +# * For outfile_ext, in a standalone build, the method will remove all the +# sub-package dependency cache files. It returns an error if the current +# build inherits from previous builds. +# * For tool, it updates the "flags" files for any changed tools. +# ------------------------------------------------------------------------------ + +for my $name (@compare_setting_methods) { + no strict 'refs'; + + *$name = sub { + my ($self, $old_lines) = @_; + + (my $prefix = uc ($name)) =~ s/^COMPARE_SETTING_//; + + my ($changed, $new_lines) = + $self->compare_setting_in_config ($prefix, $old_lines); + + my $rc = scalar (keys %$changed); + + if ($rc and $old_lines) { + $self->srcpkg ('')->is_updated (1); + + if ($name =~ /^compare_setting_bld_dep(?:_excl|_n|_pp)?$/) { + # Mark affected packages as being updated + for my $key (keys %$changed) { + for my $pkg (values %{ $self->srcpkg }) { + next unless $pkg->is_in_package ($key); + $pkg->is_updated (1); + } + } + + } elsif ($name eq 'compare_setting_bld_pp') { + # Mark affected packages as being updated + for my $key (keys %$changed) { + for my $pkg (values %{ $self->srcpkg }) { + next unless $pkg->is_in_package ($key); + next unless $self->srcpkg ($key)->is_type_any ( + keys %{ $self->setting ('BLD_TYPE_DEP_PP') } + ); # Is a type requiring pre-processing + + $pkg->is_updated (1); + } + } + + } elsif ($name eq 'compare_setting_infile_ext') { + # Re-set input file type if necessary + for my $key (keys %$changed) { + for my $pkg (values %{ $self->srcpkg }) { + next unless $pkg->src and $pkg->ext and $key eq $pkg->ext; + + $pkg->type (undef); + } + } + + # Mark affected packages as being updated + for my $pkg (values %{ $self->srcpkg }) { + $pkg->is_updated (1); + } + + } elsif ($name eq 'compare_setting_outfile_ext') { + # Mark affected packages as being updated + for my $pkg (values %{ $self->srcpkg }) { + $pkg->is_updated (1); + } + + } elsif ($name eq 'compare_setting_tool') { + # Update the "flags" files for changed tools + for my $name (sort keys %$changed) { + my ($tool, @names) = split /__/, $name; + my $pkg = join ('__', @names); + my @srcpkgs = $self->srcpkg ($pkg) + ? ($self->srcpkg ($pkg)) + : @{ $self->dummysrcpkg ($pkg)->children }; + + for my $srcpkg (@srcpkgs) { + my $file = File::Spec->catfile ( + $self->dest->flagsdir, $srcpkg->flagsbase ($tool) + ); + &touch_file ($file) or croak $file, ': cannot update, abort'; + + print $file, ': updated', "\n" if $self->verbose > 2; + } + } + } + } + + return ($rc, $new_lines); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->compare_setting_dependency ($old_lines, $flag); +# +# DESCRIPTION +# This method uses the previous settings to determine the dependencies of +# current source files. +# ------------------------------------------------------------------------------ + +sub compare_setting_dependency { + my ($self, $old_lines, $flag) = @_; + + my $prefix = $flag ? 'DEP_PP' : 'DEP'; + my $method = $flag ? 'ppdep' : 'dep'; + + my $rc = 0; + my $new_lines = []; + + # Separate old lines + my %old; + if ($old_lines) { + for my $line (@$old_lines) { + next unless $line->label_starts_with ($prefix); + $old{$line->label_from_field (1)} = $line; + } + } + + # Go through each source to see if the cache is up to date + my $count = 0; + my %mtime; + for my $srcpkg (values %{ $self->srcpkg }) { + next unless $srcpkg->cursrc and $srcpkg->type; + + my $key = $srcpkg->pkgname; + my $out_of_date = $srcpkg->is_updated; + + # Check modification time of cache and source file if not out of date + if (exists $old{$key}) { + if (not $out_of_date) { + $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9] + if not exists ($mtime{$old{$key}->src}); + + $out_of_date = 1 if $mtime{$old{$key}->src} < $srcpkg->curmtime; + } + } + else { + $out_of_date = 1; + } + + if ($out_of_date) { + # Re-scan dependency + $srcpkg->is_updated(1); + my ($source_is_read, $dep_hash_ref) = $srcpkg->get_dep($flag); + if ($source_is_read) { + $count++; + } + $srcpkg->$method($dep_hash_ref); + $rc = 1; + } + else { + # Use cached dependency + my ($progname, %hash) = split ( + /$Fcm::Config::DELIMITER_PATTERN/, $old{$key}->value + ); + $srcpkg->progname ($progname) if $progname and not $flag; + $srcpkg->$method (\%hash); + } + + # New lines values: progname[::dependency-name::type][...] + my @value = ((defined $srcpkg->progname ? $srcpkg->progname : '')); + for my $name (sort keys %{ $srcpkg->$method }) { + push @value, $name, $srcpkg->$method ($name); + } + + push @$new_lines, Fcm::CfgLine->new ( + LABEL => $prefix . $Fcm::Config::DELIMITER . $key, + VALUE => join ($Fcm::Config::DELIMITER, @value), + ); + } + + print 'No. of file', ($count > 1 ? 's' : ''), ' scanned for', + ($flag ? ' PP': ''), ' dependency: ', $count, "\n" + if $self->verbose and $count; + + return ($rc, $new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->compare_setting_srcpkg ($old_lines); +# +# DESCRIPTION +# This method uses the previous settings to determine the type of current +# source files. +# ------------------------------------------------------------------------------ + +sub compare_setting_srcpkg { + my ($self, $old_lines) = @_; + + my $prefix = 'SRCPKG'; + + # Get relevant items from old lines, stripping out $prefix + my %old; + if ($old_lines) { + for my $line (@$old_lines) { + next unless $line->label_starts_with ($prefix); + $old{$line->label_from_field (1)} = $line; + } + } + + # Check for change, use previous setting if exist + my $out_of_date = 0; + my %mtime; + for my $key (keys %{ $self->srcpkg }) { + if (exists $old{$key}) { + next unless $self->srcpkg ($key)->cursrc; + + my $type = defined $self->setting ('BLD_TYPE', $key) + ? $self->setting ('BLD_TYPE', $key) : $old{$key}->value; + + $self->srcpkg ($key)->type ($type); + + if ($type ne $old{$key}->value) { + $self->srcpkg ($key)->is_updated (1); + $out_of_date = 1; + } + + if (not $self->srcpkg ($key)->is_updated) { + $mtime{$old{$key}->src} = (stat ($old{$key}->src))[9] + if not exists ($mtime{$old{$key}->src}); + + $self->srcpkg ($key)->is_updated (1) + if $mtime{$old{$key}->src} < $self->srcpkg ($key)->curmtime; + } + + } else { + $self->srcpkg ($key)->is_updated (1); + $out_of_date = 1; + } + } + + # Check for deleted keys + for my $key (keys %old) { + next if $self->srcpkg ($key); + + $out_of_date = 1; + } + + # Return reference to an array of new lines + my $new_lines = []; + for my $key (keys %{ $self->srcpkg }) { + push @$new_lines, Fcm::CfgLine->new ( + LABEL => $prefix . $Fcm::Config::DELIMITER . $key, + VALUE => $self->srcpkg ($key)->type, + ); + } + + return ($out_of_date, $new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $new_lines) = $self->compare_setting_target ($old_lines); +# +# DESCRIPTION +# This method compare the previous target settings with current ones. +# ------------------------------------------------------------------------------ + +sub compare_setting_target { + my ($self, $old_lines) = @_; + + my $prefix = 'TARGET'; + my $old; + if ($old_lines) { + for my $line (@$old_lines) { + next unless $line->label_starts_with ($prefix); + $old = $line->value; + last; + } + } + + my $new = join (' ', sort @{ $self->target }); + + return ( + (defined ($old) ? $old ne $new : 1), + [Fcm::CfgLine->new (LABEL => $prefix, VALUE => $new)], + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_fortran_interface_generator (); +# +# DESCRIPTION +# This method invokes the Fortran interface generator for all Fortran free +# format source files. It returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_fortran_interface_generator { + my $self = shift; + + my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/); + + # Set up build task to generate interface files for all selected Fortran 9x + # sources + my %task = (); + SRC_FILE: + for my $srcfile (values %{ $self->srcpkg }) { + if (!defined($srcfile->interfacebase())) { + next SRC_FILE; + } + my $target = $srcfile->interfacebase . $pdoneext; + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->donepath, + SRCFILE => $srcfile, + DEPENDENCY => [$srcfile->flagsbase ('GENINTERFACE')], + ACTIONTYPE => 'GENINTERFACE', + ); + + # Set up build tasks for each source file/package flags file for interface + # generator tool + for my $i (1 .. @{ $srcfile->pkgnames }) { + my $target = $srcfile->flagsbase ('GENINTERFACE', -$i); + my $depend = $i < @{ $srcfile->pkgnames } + ? $srcfile->flagsbase ('GENINTERFACE', -$i - 1) + : undef; + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->flagspath, + DEPENDENCY => [defined ($depend) ? $depend : ()], + ACTIONTYPE => 'UPDATE', + ) if not exists $task{$target}; + } + } + + # Set up build task to update the flags file for interface generator tool + $task{$self->srcpkg ('')->flagsbase ('GENINTERFACE')} = Fcm::BuildTask->new ( + TARGET => $self->srcpkg ('')->flagsbase ('GENINTERFACE'), + TARGETPATH => $self->dest->flagspath, + ACTIONTYPE => 'UPDATE', + ); + + my $count = 0; + + # Performs task + for my $task (values %task) { + next unless $task->actiontype eq 'GENINTERFACE'; + + my $rc = $task->action (TASKLIST => \%task); + $count++ if $rc; + } + + print 'No. of generated Fortran interface', ($count > 1 ? 's' : ''), ': ', + $count, "\n" + if $self->verbose and $count; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_make (%args); +# +# DESCRIPTION +# This method invokes the make stage of the build system. It returns true on +# success. +# +# ARGUMENTS +# ARCHIVE - If set to "true", invoke the "archive" mode. Most build files and +# directories created by this build will be archived using the +# "tar" command. If not set, the default is not to invoke the +# "archive" mode. +# JOBS - Specify number of jobs that can be handled by "make". If set, the +# value must be a natural integer. If not set, the default value is +# 1 (i.e. run "make" in serial mode). +# TARGETS - Specify targets to be built. If set, these targets will be built +# instead of the ones specified in the build configuration file. +# ------------------------------------------------------------------------------ + +sub invoke_make { + my ($self, %args) = @_; + $args{TARGETS} ||= ['all']; + $args{JOBS} ||= 1; + my @command = ( + $self->setting(qw/TOOL MAKE/), + shellwords($self->setting(qw/TOOL MAKEFLAGS/)), + # -f Makefile + ($self->setting(qw/TOOL MAKE_FILE/), $self->dest()->bldmakefile()), + # -j N + ($args{JOBS} ? ($self->setting(qw/TOOL MAKE_JOB/), $args{JOBS}) : ()), + # -s + ($self->verbose() >= 3 ? $self->setting(qw/TOOL MAKE_SILENT/) : ()), + @{$args{TARGETS}} + ); + my $old_cwd = $self->_chdir($self->dest()->rootdir()); + run_command( + \@command, ERROR => 'warn', RC => \my($code), TIME => $self->verbose() >= 3, + ); + $self->_chdir($old_cwd); + + my $rc = !$code; + if ($rc && $args{ARCHIVE}) { + $rc = $self->dest()->archive(); + } + $rc &&= $self->dest()->create_bldrunenvsh(); + while (my ($key, $source) = each(%{$self->srcpkg()})) { + $rc &&= defined($source->write_lib_dep_excl()); + } + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_pre_process (); +# +# DESCRIPTION +# This method invokes the pre-process stage of the build system. It +# returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_pre_process { + my $self = shift; + + # Check whether pre-processing is necessary + my $invoke = 0; + for (values %{ $self->srcpkg }) { + next unless $_->get_setting ('BLD_PP'); + $invoke = 1; + last; + } + return 1 unless $invoke; + + # Scan header dependency + my $rc = $self->compare_setting ( + METHOD_LIST => ['compare_setting_dependency'], + METHOD_ARGS => ['BLD_TYPE_DEP_PP'], + CACHEBASE => $self->setting ('CACHE_DEP_PP'), + ); + + return $rc if not $rc; + + my %task = (); + my $pdoneext = $self->setting (qw/OUTFILE_EXT PDONE/); + + # Set up tasks for each source file + for my $srcfile (values %{ $self->srcpkg }) { + if ($srcfile->is_type_all (qw/CPP INCLUDE/)) { + # Set up a copy build task for each include file + $task{$srcfile->base} = Fcm::BuildTask->new ( + TARGET => $srcfile->base, + TARGETPATH => $self->dest->incpath, + SRCFILE => $srcfile, + DEPENDENCY => [keys %{ $srcfile->ppdep }], + ACTIONTYPE => 'COPY', + ); + + } elsif ($srcfile->lang ('TOOL_SRC_PP')) { + next unless $srcfile->get_setting ('BLD_PP'); + + # Set up a PP build task for each source file + my $target = $srcfile->base . $pdoneext; + + # Issue warning for duplicated tasks + if (exists $task{$target}) { + w_report 'WARNING: ', $target, ': unable to create task for: ', + $srcfile->src, ': task already exists for: ', + $task{$target}->srcfile->src; + next; + } + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->donepath, + SRCFILE => $srcfile, + DEPENDENCY => [$srcfile->flagsbase ('PPKEYS'), keys %{ $srcfile->ppdep }], + ACTIONTYPE => 'PP', + ); + + # Set up update ppkeys/flags build tasks for each source file/package + my $ppkeys = $self->setting ( + 'TOOL_SRC_PP', $srcfile->lang ('TOOL_SRC_PP'), 'PPKEYS' + ); + + for my $i (1 .. @{ $srcfile->pkgnames }) { + my $target = $srcfile->flagsbase ($ppkeys, -$i); + my $depend = $i < @{ $srcfile->pkgnames } + ? $srcfile->flagsbase ($ppkeys, -$i - 1) + : undef; + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->flagspath, + DEPENDENCY => [defined ($depend) ? $depend : ()], + ACTIONTYPE => 'UPDATE', + ) if not exists $task{$target}; + } + } + } + + # Set up update global ppkeys build tasks + for my $lang (keys %{ $self->setting ('TOOL_SRC_PP') }) { + my $target = $self->srcpkg ('')->flagsbase ( + $self->setting ('TOOL_SRC_PP', $lang, 'PPKEYS') + ); + + $task{$target} = Fcm::BuildTask->new ( + TARGET => $target, + TARGETPATH => $self->dest->flagspath, + ACTIONTYPE => 'UPDATE', + ); + } + + # Build all PP tasks + my $count = 0; + for my $task (values %task) { + next unless $task->actiontype eq 'PP'; + + my $rc = $task->action (TASKLIST => \%task); + $task->srcfile->is_updated ($rc); + $count++ if $rc; + } + + print 'No. of pre-processed file', ($count > 1 ? 's' : ''), ': ', $count, "\n" + if $self->verbose and $count; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_scan_dependency (); +# +# DESCRIPTION +# This method invokes the scan dependency stage of the build system. It +# returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_scan_dependency { + my $self = shift; + + # Scan/retrieve dependency + # ---------------------------------------------------------------------------- + my $rc = $self->compare_setting ( + METHOD_LIST => ['compare_setting_dependency'], + CACHEBASE => $self->setting ('CACHE_DEP'), + ); + + # Check whether make file is out of date + # ---------------------------------------------------------------------------- + my $out_of_date = not -r $self->dest->bldmakefile; + + if ($rc and not $out_of_date) { + for (qw/CACHE CACHE_DEP/) { + my $cache_mtime = (stat (File::Spec->catfile ( + $self->dest->cachedir, $self->setting ($_), + )))[9]; + my $mfile_mtime = (stat ($self->dest->bldmakefile))[9]; + + next if not defined $cache_mtime; + next if $cache_mtime < $mfile_mtime; + $out_of_date = 1; + last; + } + } + + if ($rc and not $out_of_date) { + for (values %{ $self->srcpkg }) { + next unless $_->is_updated; + $out_of_date = 1; + last; + } + } + + if ($rc and $out_of_date) { + # Write Makefile + # -------------------------------------------------------------------------- + # Register non-word package name + my $unusual = 0; + for my $key (sort keys %{ $self->srcpkg }) { + next if $self->srcpkg ($key)->src; + next if $key =~ /^\w*$/; + + $self->setting ( + ['FCM_PCK_OBJECTS', $key], 'FCM_PCK_OBJECTS' . $unusual++, + ); + } + + # Write different parts in the Makefile + my $makefile = '# Automatic Makefile' . "\n\n"; + $makefile .= 'FCM_BLD_NAME = ' . $self->name . "\n" if $self->name; + $makefile .= 'FCM_BLD_CFG = ' . $self->cfg->actual_src . "\n"; + $makefile .= 'export FCM_VERBOSE ?= ' . $self->verbose . "\n\n"; + $makefile .= $self->dest->write_rules; + $makefile .= $self->_write_makefile_perl5lib; + $makefile .= $self->_write_makefile_tool; + $makefile .= $self->_write_makefile_vpath; + $makefile .= $self->_write_makefile_target; + + # Write rules for each source package + # Ensure that container packages come before files - this allows $(OBJECTS) + # and its dependent variables to expand correctly + my @srcpkg = sort { + if ($self->srcpkg ($a)->libbase and $self->srcpkg ($b)->libbase) { + $b cmp $a; + + } elsif ($self->srcpkg ($a)->libbase) { + -1; + + } elsif ($self->srcpkg ($b)->libbase) { + 1; + + } else { + $a cmp $b; + } + } keys %{ $self->srcpkg }; + + for (@srcpkg) { + $makefile .= $self->srcpkg ($_)->write_rules if $self->srcpkg ($_)->rules; + } + $makefile .= '# EOF' . "\n"; + + # Update Makefile + open OUT, '>', $self->dest->bldmakefile + or croak $self->dest->bldmakefile, ': cannot open (', $!, '), abort'; + print OUT $makefile; + close OUT + or croak $self->dest->bldmakefile, ': cannot close (', $!, '), abort'; + + print $self->dest->bldmakefile, ': updated', "\n" if $self->verbose; + + # Check for duplicated targets + # -------------------------------------------------------------------------- + # Get list of types that cannot have duplicated targets + my @no_duplicated_target_types = split ( + /$DELIMITER_LIST/, + $self->setting ('BLD_TYPE_NO_DUPLICATED_TARGET'), + ); + + my %targets; + for my $name (sort keys %{ $self->srcpkg }) { + next unless $self->srcpkg ($name)->rules; + + for my $key (sort keys %{ $self->srcpkg ($name)->rules }) { + if (exists $targets{$key}) { + # Duplicated target: warning for most file types + my $status = 'WARNING'; + + # Duplicated target: error for the following file types + if (@no_duplicated_target_types and + $self-srcpkg ($name)->is_type_any (@no_duplicated_target_types) and + $targets{$key}->is_type_any (@no_duplicated_target_types)) { + $status = 'ERROR'; + $rc = 0; + } + + # Report the warning/error + w_report $status, ': ', $key, ': duplicated targets for building:'; + w_report ' ', $targets{$key}->src; + w_report ' ', $self->srcpkg ($name)->src; + + } else { + $targets{$key} = $self->srcpkg ($name); + } + } + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_setup_build (); +# +# DESCRIPTION +# This method invokes the setup_build stage of the build system. It returns +# true on success. +# ------------------------------------------------------------------------------ + +sub invoke_setup_build { + my $self = shift; + + my $rc = 1; + + # Extract archived sub-directories if necessary + $rc = $self->dest->dearchive if $rc; + + # Compare cache + $rc = $self->compare_setting (METHOD_LIST => [ + 'compare_setting_target', # targets + 'compare_setting_srcpkg', # source package type + @compare_setting_methods, + ]) if $rc; + + # Set up runtime dependency scan patterns + my %dep_pattern = %{ $self->setting ('BLD_DEP_PATTERN') }; + for my $key (keys %dep_pattern) { + my $pattern = $dep_pattern{$key}; + + while ($pattern =~ /##([\w:]+)##/g) { + my $match = $1; + my $val = $self->setting (split (/$Fcm::Config::DELIMITER/, $match)); + + last unless defined $val; + $val =~ s/\./\\./; + + $pattern =~ s/##$match##/$val/; + } + + $self->setting (['BLD_DEP_PATTERN', $key], $pattern) + unless $pattern eq $dep_pattern{$key}; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_system (%args); +# +# DESCRIPTION +# This method invokes the build system. It returns true on success. See also +# the header for invoke_make for further information on arguments. +# +# ARGUMENTS +# STAGE - If set, it should be an integer number or a recognised keyword or +# abbreviation. If set, the build is performed up to the named stage. +# If not set, the default is to perform all stages of the build. +# Allowed values are: +# 1, setup or s +# 2, pre_process or pp +# 3, generate_dependency or gd +# 4, generate_interface or gi +# 5, all, a, make or m +# ------------------------------------------------------------------------------ + +sub invoke_system { + my $self = shift; + my %args = @_; + + # Parse arguments + # ---------------------------------------------------------------------------- + # Default: run all 5 stages + my $stage = (exists $args{STAGE} and $args{STAGE}) ? $args{STAGE} : 5; + + # Resolve named stages + if ($stage !~ /^\d$/) { + my %stagenames = ( + 'S(?:ETUP)?' => 1, + 'P(?:RE)?_?P(?:ROCESS)?' => 2, + 'G(?:ENERATE)?_?D(?:ENPENDENCY)?' => 3, + 'G(?:ENERATE)?_?I(?:NTERFACE)?' => 4, + '(?:A(?:LL)|M(?:AKE)?)' => 5, + ); + + # Does it match a recognised stage? + for my $name (keys %stagenames) { + next unless $stage =~ /$name/i; + + $stage = $stagenames{$name}; + last; + } + + # Specified stage name not recognised, default to 5 + if ($stage !~ /^\d$/) { + w_report 'WARNING: ', $stage, ': invalid build stage, default to 5.'; + $stage = 5; + } + } + + # Run the method associated with each stage + # ---------------------------------------------------------------------------- + my $rc = 1; + + my @stages = ( + ['Setup build' , 'invoke_setup_build'], + ['Pre-process' , 'invoke_pre_process'], + ['Scan dependency' , 'invoke_scan_dependency'], + ['Generate Fortran interface', 'invoke_fortran_interface_generator'], + ['Make' , 'invoke_make'], + ); + + for my $i (1 .. 5) { + last if (not $rc) or $i > $stage; + + my ($name, $method) = @{ $stages[$i - 1] }; + $rc = $self->invoke_stage ($name, $method, %args) if $rc and $stage >= $i; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_dep (\@cfg_lines); +# +# DESCRIPTION +# This method parses the dependency settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_dep { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + + # EXCL_DEP, EXE_DEP and BLOCKDATA declarations + # ---------------------------------------------------------------------------- + for my $name (qw/BLD_BLOCKDATA BLD_DEP BLD_DEP_EXCL BLD_DEP_EXE/) { + for my $line (grep {$_->slabel_starts_with_cfg ($name)} @$cfg_lines) { + # Separate label into a list, delimited by double-colon, remove 1st field + my @flds = $line->slabel_fields; + shift @flds; + + if ($name =~ /^(?:BLD_DEP|BLD_DEP_EXCL|BLD_DEP_PP)$/) { + # BLD_DEP_*: label fields may contain sub-package + my $pk = @flds ? join ('__', @flds) : ''; + + # Check whether sub-package is valid + if ($pk and not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) { + $line->error ($line->label . ': invalid sub-package in declaration.'); + $rc = 0; + next; + } + + # Setting is stored in an array reference + $self->setting ([$name, $pk], []) + if not defined $self->setting ($name, $pk); + + # Add current declaration to the array if necessary + my $list = $self->setting ($name, $pk); + my $value = $name eq 'BLD_DEP_EXCL' ? uc ($line->value) : $line->value; + push @$list, $value if not grep {$_ eq $value} @$list; + + } else { + # EXE_DEP and BLOCKDATA: label field may be an executable target + my $target = @flds ? $flds[0] : ''; + + # The value contains a list of objects and/or sub-package names + my @deps = split /\s+/, $line->value; + + if (not @deps) { + if ($name eq 'BLD_BLOCKDATA') { + # The objects containing a BLOCKDATA program unit must be declared + $line->error ($line->label . ': value not set.'); + $rc = 0; + next; + + } else { + # If $value is a null string, target(s) depends on all objects + push @deps, ''; + } + } + + for my $dep (@deps) { + $dep =~ s/$Fcm::Config::DELIMITER_PATTERN/__/g; + } + + $self->setting ([$name, $target], join (' ', sort @deps)); + } + + $line->parsed (1); + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_dest (\@cfg_lines); +# +# DESCRIPTION +# This method parses the build destination settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_dest { + my ($self, $cfg_lines) = @_; + + my $rc = $self->SUPER::parse_cfg_dest ($cfg_lines); + + # Set up search paths + for my $name (@Fcm::Dest::paths) { + (my $label = uc ($name)) =~ s/PATH//; + + $self->setting (['PATH', $label], $self->dest->$name); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_misc (\@cfg_lines); +# +# DESCRIPTION +# This method parses misc build settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_misc { + my ($self, $cfg_lines_ref) = @_; + my $rc = 1; + my %item_of = ( + BLD_DEP_N => [\&_parse_cfg_misc_dep_n , 1 ], # boolean + BLD_EXE_NAME => [\&_parse_cfg_misc_exe_name ], + BLD_LIB => [\&_parse_cfg_misc_dep_n ], + BLD_PP => [\&_parse_cfg_misc_dep_n , 1 ], # boolean + BLD_TYPE => [\&_parse_cfg_misc_dep_n ], + INFILE_EXT => [\&_parse_cfg_misc_file_ext, 0, 1], # uc($value) + OUTFILE_EXT => [\&_parse_cfg_misc_file_ext, 1, 0], # uc($ns) + ); + while (my ($key, $item) = each(%item_of)) { + my ($handler, @extra_arguments) = @{$item}; + for my $line (@{$cfg_lines_ref}) { + if ($line->slabel_starts_with_cfg($key)) { + if ($handler->($self, $key, $line, @extra_arguments)) { + $line->parsed(1); + } + else { + $rc = 0; + } + } + } + } + return $rc; +} + +# ------------------------------------------------------------------------------ +# parse_cfg_misc: handler of BLD_EXE_NAME or similar. +sub _parse_cfg_misc_exe_name { + my ($self, $key, $line) = @_; + my ($prefix, $name, @fields) = $line->slabel_fields(); + if (!$name || @fields) { + $line->error(sprintf('%s: expects a single label name field.', $key)); + return 0; + } + $self->setting([$key, $name], $line->value()); + return 1; +} + +# ------------------------------------------------------------------------------ +# parse_cfg_misc: handler of BLD_DEP_N or similar. +sub _parse_cfg_misc_dep_n { + my ($self, $key, $line, $value_is_boolean) = @_; + my ($prefix, @fields) = $line->slabel_fields(); + my $ns = @fields ? join(q{__}, @fields) : q{}; + if ($ns && !$self->srcpkg($ns) && !$self->dummysrcpkg($ns)) { + $line->error($line->label() . ': invalid sub-package in declaration.'); + return 0; + } + my @srcpkgs + = $self->dummysrcpkg($ns) ? @{$self->dummysrcpkg($ns)->children()} + : $self->srcpkg($ns) + ; + my $value = $value_is_boolean ? $line->bvalue() : $line->value(); + for my $srcpkg (@srcpkgs) { + $self->setting([$key, $srcpkg->pkgname()], $value); + } + return 1; +} + +# ------------------------------------------------------------------------------ +# parse_cfg_misc: handler of INFILE_EXT/OUTFILE_EXT or similar. +sub _parse_cfg_misc_file_ext { + my ($self, $key, $line, $ns_in_uc, $value_in_uc) = @_; + my ($prefix, $ns) = $line->slabel_fields(); + my $value = $value_in_uc ? uc($line->value()) : $line->value(); + $self->setting([$key, ($ns_in_uc ? uc($ns) : $ns)], $value); + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_source (\@cfg_lines); +# +# DESCRIPTION +# This method parses the source package settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_source { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + my %src = (); + + # Automatic source directory search? + # ---------------------------------------------------------------------------- + my $search = 1; + + for my $line (grep {$_->slabel_starts_with_cfg ('SEARCH_SRC')} @$cfg_lines) { + $search = $line->bvalue; + $line->parsed (1); + } + + # Search src/ sub-directory if necessary + %src = %{ $self->dest->get_source_files } if $search; + + # SRC declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('FILE')} @$cfg_lines) { + # Expand ~ notation and path relative to srcdir of destination + my $value = $line->value; + $value = File::Spec->rel2abs (&expand_tilde ($value), $self->dest->srcdir); + + if (not -r $value) { + $line->error ($value . ': source does not exist or is not readable.'); + next; + } + + # Package name + my @names = $line->slabel_fields; + shift @names; + + # If package name not set, determine using the path if possible + if (not @names) { + my $package = $self->dest->get_pkgname_of_path ($value); + @names = @$package if defined $package; + } + + if (not @names) { + $line->error ($self->cfglabel ('FILE') . + ': package not specified/cannot be determined.'); + next; + } + + $src{join ('__', @names)} = $value; + + $line->parsed (1); + } + + # For directories, get non-recursive file listing, and add to %src + # ---------------------------------------------------------------------------- + for my $key (keys %src) { + next unless -d $src{$key}; + + opendir DIR, $src{$key} or die $src{$key}, ': cannot read directory'; + while (my $base = readdir 'DIR') { + next if $base =~ /^\./; + + my $file = File::Spec->catfile ($src{$key}, $base); + next unless -f $file and -r $file; + + my $name = join ('__', ($key, $base)); + $src{$name} = $file unless exists $src{$name}; + } + closedir DIR; + + delete $src{$key}; + } + + # Set up source packages + # ---------------------------------------------------------------------------- + my %pkg = (); + for my $name (keys %src) { + $pkg{$name} = Fcm::BuildSrc->new (PKGNAME => $name, SRC => $src{$name}); + } + + # INHERIT::SRC declarations + # ---------------------------------------------------------------------------- + my %can_inherit = (); + for my $line ( + grep {$_->slabel_starts_with_cfg(qw/INHERIT FILE/)} @{$cfg_lines} + ) { + my ($key1, $key2, @ns) = $line->slabel_fields(); + $can_inherit{join('__', @ns)} = $line->bvalue(); + $line->parsed(1); + } + + # Inherit packages, if it is OK to do so + for my $inherited_build (reverse(@{$self->inherit()})) { + SRCPKG: + while (my ($key, $srcpkg) = each(%{$inherited_build->srcpkg()})) { + if (exists($pkg{$key}) || !$srcpkg->src()) { + next SRCPKG; + } + my $known_key = first {exists($can_inherit{$_})} @{$srcpkg->pkgnames()}; + if (defined($known_key) && !$can_inherit{$known_key}) { + next SRCPKG; + } + $pkg{$key} = $srcpkg; + } + } + + # Get list of intermediate "packages" + # ---------------------------------------------------------------------------- + for my $name (keys %pkg) { + # Name of current package + my @names = split /__/, $name; + + my $cur = $name; + + while ($cur) { + # Name of parent package + pop @names; + my $parent = @names ? join ('__', @names) : ''; + + # If parent package does not exist, create it + $pkg{$parent} = Fcm::BuildSrc->new (PKGNAME => $parent) + unless exists $pkg{$parent}; + + # Current package is a child of the parent package + push @{ $pkg{$parent}->children }, $pkg{$cur} + unless grep {$_->pkgname eq $cur} @{ $pkg{$parent}->children }; + + # Go up a package + $cur = $parent; + } + } + + $self->srcpkg (\%pkg); + + # Dummy: e.g. "foo/bar/baz.egg" belongs to the "foo/bar/baz" dummy. + # ---------------------------------------------------------------------------- + for my $name (keys %pkg) { + (my $dname = $name) =~ s/\.\w+$//; + next if $dname eq $name; + next if $self->srcpkg ($dname); + + $self->dummysrcpkg ($dname, Fcm::BuildSrc->new (PKGNAME => $dname)) + unless $self->dummysrcpkg ($dname); + push @{ $self->dummysrcpkg ($dname)->children }, $pkg{$name}; + } + + # Make sure a package is defined + # ---------------------------------------------------------------------------- + if (not %{$self->srcpkg}) { + w_report 'ERROR: ', $self->cfg->actual_src, ': no source file to build.'; + $rc = 0; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_target (\@cfg_lines); +# +# DESCRIPTION +# This method parses the target settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_target { + my ($self, $cfg_lines) = @_; + + # NAME declaraions + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('NAME')} @$cfg_lines) { + $self->name ($line->value); + $line->parsed (1); + } + + # TARGET declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('TARGET')} @$cfg_lines) { + # Value is a space delimited list + push @{ $self->target }, split (/\s+/, $line->value); + $line->parsed (1); + } + + # INHERIT::TARGET declarations + # ---------------------------------------------------------------------------- + # By default, do not inherit target + my $inherit_flag = 0; + + for (grep {$_->slabel_starts_with_cfg (qw/INHERIT TARGET/)} @$cfg_lines) { + $inherit_flag = $_->bvalue; + $_->parsed (1); + } + + # Inherit targets from inherited build, if $inherit_flag is set to true + # ---------------------------------------------------------------------------- + if ($inherit_flag) { + for my $use (reverse @{ $self->inherit }) { + unshift @{ $self->target }, @{ $use->target }; + } + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_tool (\@cfg_lines); +# +# DESCRIPTION +# This method parses the tool settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_tool { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + + my %tools = %{ $self->setting ('TOOL') }; + my @package_tools = split(/$DELIMITER_LIST/, $self->setting('TOOL_PACKAGE')); + + # TOOL declaration + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('TOOL')} @$cfg_lines) { + # Separate label into a list, delimited by double-colon, remove TOOL + my @flds = $line->slabel_fields; + shift @flds; + + # Check that there is a field after TOOL + if (not @flds) { + $line->error ('TOOL: not followed by a valid label.'); + $rc = 0; + next; + } + + # The first field is the tool iteself, identified in uppercase + $flds[0] = uc ($flds[0]); + + # Check that the tool is recognised + if (not exists $tools{$flds[0]}) { + $line->error ($flds[0] . ': not a valid TOOL.'); + $rc = 0; + next; + } + + # Check sub-package declaration + if (@flds > 1 and not grep {$_ eq $flds[0]} @package_tools) { + $line->error ($flds[0] . ': sub-package not accepted with this TOOL.'); + $rc = 0; + next; + } + + # Name of declared package + my $pk = join ('__', @flds[1 .. $#flds]); + + # Check whether package exists + if (not ($self->srcpkg ($pk) or $self->dummysrcpkg ($pk))) { + $line->error ($line->label . ': invalid sub-package in declaration.'); + $rc = 0; + next; + } + + $self->setting (['TOOL', join ('__', @flds)], $line->value); + $line->parsed (1); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_perl5lib (); +# +# DESCRIPTION +# This method returns a makefile $string for defining $PERL5LIB. +# ------------------------------------------------------------------------------ + +sub _write_makefile_perl5lib { + my $self = shift; + + my $classpath = File::Spec->catfile (split (/::/, ref ($self))) . '.pm'; + + my $libdir = dirname (dirname ($INC{$classpath})); + my @libpath = split (/:/, (exists $ENV{PERL5LIB} ? $ENV{PERL5LIB} : '')); + + my $string = ((grep {$_ eq $libdir} @libpath) + ? '' + : 'export PERL5LIB := ' . $libdir . + (exists $ENV{PERL5LIB} ? ':$(PERL5LIB)' : '') . "\n\n"); + + return $string; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_target (); +# +# DESCRIPTION +# This method returns a makefile $string for defining the default targets. +# ------------------------------------------------------------------------------ + +sub _write_makefile_target { + my $self = shift; + + # Targets of the build + # ---------------------------------------------------------------------------- + my @targets = @{ $self->target }; + if (not @targets) { + # Build targets not specified by user, default to building all main programs + my @programs = (); + + # Get all main programs from all packages + for my $pkg (values %{ $self->srcpkg }) { + push @programs, $pkg->exebase if $pkg->exebase; + } + + @programs = sort (@programs); + + if (@programs) { + # Build main programs, if there are any + @targets = @programs; + + } else { + # No main program in source tree, build the default library + @targets = ($self->srcpkg ('')->libbase); + } + } + + my $return = 'FCM_BLD_TARGETS = ' . join (' ', @targets) . "\n\n"; + + # Default targets + $return .= '.PHONY : all' . "\n\n"; + $return .= 'all : $(FCM_BLD_TARGETS)' . "\n\n"; + + # Targets for copy dummy + $return .= sprintf("%s:\n\ttouch \$@\n\n", $self->setting(qw/BLD_CPDUMMY/)); + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_tool (); +# +# DESCRIPTION +# This method returns a makefile $string for defining the build tools. +# ------------------------------------------------------------------------------ + +sub _write_makefile_tool { + my $self = shift; + + # List of build tools + my $tool = $self->setting ('TOOL'); + + # List of tools local to FCM, (will not be exported) + my %localtool = map {($_, 1)} split ( # map into a hash table + /$DELIMITER_LIST/, $self->setting ('TOOL_LOCAL'), + ); + + # Export required tools + my $count = 0; + my $return = ''; + for my $name (sort keys %$tool) { + # Ignore local tools + next if exists $localtool{(split (/__/, $name))[0]}; + + if ($name =~ /^\w+$/) { + # Tools with normal name, just export it as an environment variable + $return .= 'export ' . $name . ' = ' . $tool->{$name} . "\n"; + + } else { + # Tools with unusual characters, export using a label/value pair + $return .= 'export FCM_UNUSUAL_TOOL_LABEL' . $count . ' = ' . $name . "\n"; + $return .= 'export FCM_UNUSUAL_TOOL_VALUE' . $count . ' = ' . + $tool->{$name} . "\n"; + $count++; + } + } + + $return .= "\n"; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_write_makefile_vpath (); +# +# DESCRIPTION +# This method returns a makefile $string for defining vpath directives. +# ------------------------------------------------------------------------------ + +sub _write_makefile_vpath { + my $self = shift(); + my $FMT = 'vpath %%%s $(FCM_%sPATH)'; + my %SETTING_OF = %{$self->setting('BLD_VPATH')}; + my %EXT_OF = %{$self->setting('OUTFILE_EXT')}; + # Note: each setting can be either an empty string or a comma-separated list + # of output file extension keys. + join( + "\n", + ( + map + { + my $key = $_; + my @types = split(qr{$DELIMITER_LIST}msx, $SETTING_OF{$key}); + @types ? (map {sprintf($FMT, $EXT_OF{$_}, $key)} sort @types) + : sprintf($FMT, q{}, $key) + ; + } + sort keys(%SETTING_OF) + ), + ) . "\n\n"; +} + +# Wraps chdir. Returns the old working directory. +sub _chdir { + my ($self, $path) = @_; + if ($self->verbose() >= 3) { + printf("cd %s\n", $path); + } + my $old_cwd = cwd(); + chdir($path) || croak(sprintf("%s: cannot change directory ($!)\n", $path)); + $old_cwd; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Build/Fortran.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Build/Fortran.pm new file mode 100644 index 0000000..618dba8 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Build/Fortran.pm @@ -0,0 +1,536 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +# ------------------------------------------------------------------------------ +package Fcm::Build::Fortran; + +use Text::Balanced qw{extract_bracketed extract_delimited}; + +# Actions of this class +my %ACTION_OF = (extract_interface => \&_extract_interface); + +# Regular expressions +# Matches a variable attribute +my $RE_ATTR = qr{ + allocatable|dimension|external|intent|optional|parameter|pointer|save|target +}imsx; +# Matches a name +my $RE_NAME = qr{[A-Za-z]\w*}imsx; +# Matches a specification type +my $RE_SPEC = qr{ + character|complex|double\s*precision|integer|logical|real|type +}imsx; +# Matches the identifier of a program unit that does not have arguments +my $RE_UNIT_BASE = qr{block\s*data|module|program}imsx; +# Matches the identifier of a program unit that has arguments +my $RE_UNIT_CALL = qr{function|subroutine}imsx; +# Matches the identifier of any program unit +my $RE_UNIT = qr{$RE_UNIT_BASE|$RE_UNIT_CALL}msx; +my %RE = ( + # A comment line + COMMENT => qr{\A\s*(?:!|\z)}msx, + # A trailing comment, capture the expression before the comment + COMMENT_END => qr{\A([^'"]*?)\s*!.*\z}msx, + # A contination marker, capture the expression before the marker + CONT => qr{\A(.*)&\s*\z}msx, + # A contination marker at the beginning of a line, capture the marker and + # the expression after the marker + CONT_LEAD => qr{\A(\s*&)(.*)\z}msx, + # Capture a variable identifier, removing any type component expression + NAME_COMP => qr{\b($RE_NAME)(?:\s*\%\s*$RE_NAME)*\b}msx, + # Matches the first identifier in a line + NAME_LEAD => qr{\A\s*$RE_NAME\s*}msx, + # Captures a name identifier after a comma, and the expression after + NAME_LIST => qr{\A(?:.*?)\s*,\s*($RE_NAME)\b(.*)\z}msx, + # Captures the next quote character + QUOTE => qr{\A[^'"]*(['"])}msx, + # Matches an attribute declaration + TYPE_ATTR => qr{\A\s*($RE_ATTR)\b}msx, + # Matches a type declaration + TYPE_SPEC => qr{\A\s*($RE_SPEC)\b}msx, + # Captures the expression after one or more program unit attributes + UNIT_ATTR => qr{\A\s*(?:(?:elemental|recursive|pure)\s+)+(.*)\z}imsx, + # Captures the identifier and the symbol of a program unit with no arguments + UNIT_BASE => qr{\A\s*($RE_UNIT_BASE)\s+($RE_NAME)\s*\z}imsx, + # Captures the identifier and the symbol of a program unit with arguments + UNIT_CALL => qr{\A\s*($RE_UNIT_CALL)\s+($RE_NAME)\b}imsx, + # Captures the end of a program unit, its identifier and its symbol + UNIT_END => qr{\A\s*(end)(?:\s+($RE_NAME)(?:\s+($RE_NAME))?)?\s*\z}imsx, + # Captures the expression after a program unit type specification + UNIT_SPEC => qr{\A\s*$RE_SPEC\b(.*)\z}imsx, +); + +# Keywords in type declaration statements +my %TYPE_DECL_KEYWORD_SET = map { ($_, 1) } qw{ + allocatable + dimension + in + inout + intent + kind + len + optional + out + parameter + pointer + save + target +}; + +# Creates and returns an instance of this class. +sub new { + my ($class) = @_; + bless( + sub { + my $key = shift(); + if (!exists($ACTION_OF{$key})) { + return; + } + $ACTION_OF{$key}->(@_); + }, + $class, + ); +} + +# Methods. +for my $key (keys(%ACTION_OF)) { + no strict qw{refs}; + *{$key} = sub { my $self = shift(); $self->($key, @_) }; +} + +# Extracts the calling interfaces of top level subroutines and functions from +# the $handle for reading Fortran sources. +sub _extract_interface { + my ($handle) = @_; + map { _present_line($_) } @{_reduce_to_interface(_load($handle))}; +} + +# Reads $handle for the next Fortran statement, handling continuations. +sub _load { + my ($handle) = @_; + my $ctx = {signature_token_set_of => {}, statements => []}; + my $state = { + in_contains => undef, # in a "contains" section of a program unit + in_interface => undef, # in an "interface" block + in_quote => undef, # in a multi-line quote + stack => [], # program unit stack + }; + my $NEW_STATEMENT = sub { + { name => q{}, # statement name, e.g. function, integer, ... + lines => [], # original lines in the statement + line_number => 0, # line number (start) in the original source + symbol => q{}, # name of a program unit (signature, end) + type => q{}, # e.g. signature, use, type, attr, end + value => q{}, # the actual value of the statement + }; + }; + my $statement; +LINE: + while (my $line = readline($handle)) { + if (!defined($statement)) { + $statement = $NEW_STATEMENT->(); + } + my $value = $line; + chomp($value); + # Pre-processor directives and continuation + if (!$statement->{line_number} && index($value, '#') == 0) { + $statement->{line_number} = $.; + $statement->{name} = 'cpp'; + } + if ($statement->{name} eq 'cpp') { + push(@{$statement->{lines}}, $line); + $statement->{value} .= $value; + if (rindex($value, '\\') != length($value) - 1) { + $statement = undef; + } + next LINE; + } + # Normal Fortran + if ($value =~ $RE{COMMENT}) { + next LINE; + } + if (!$statement->{line_number}) { + $statement->{line_number} = $.; + } + my ($cont_head, $cont_tail); + if ($statement->{line_number} != $.) { # is a continuation + ($cont_head, $cont_tail) = $value =~ $RE{CONT_LEAD}; + if ($cont_head) { + $value = $cont_tail; + } + } + # Correctly handle ! and & in quotes + my ($head, $tail) = (q{}, $value); + if ($state->{in_quote} && index($value, $state->{in_quote}) >= 0) { + my $index = index($value, $state->{in_quote}); + $head = substr($value, 0, $index + 1); + $tail + = length($value) > $index + 1 + ? substr($value, $index + 2) + : q{}; + $state->{in_quote} = undef; + } + if (!$state->{in_quote}) { + while ($tail) { + if (index($tail, q{!}) >= 0) { + if (!($tail =~ s/$RE{COMMENT_END}/$1/)) { + ($head, $tail, $state->{in_quote}) + = _load_extract_quote($head, $tail); + } + } + else { + while (index($tail, q{'}) > 0 + || index($tail, q{"}) > 0) + { + ($head, $tail, $state->{in_quote}) + = _load_extract_quote($head, $tail); + } + $head .= $tail; + $tail = q{}; + } + } + } + $cont_head ||= q{}; + push(@{$statement->{lines}}, $cont_head . $head . $tail . "\n"); + $statement->{value} .= $head . $tail; + # Process a statement only if it is marked with a continuation + if (!($statement->{value} =~ s/$RE{CONT}/$1/)) { + $statement->{value} =~ s{\s+\z}{}msx; + if (_process($statement, $ctx, $state)) { + push(@{$ctx->{statements}}, $statement); + } + $statement = undef; + } + } + return $ctx; +} + +# Helper, removes a quoted string from $tail. +sub _load_extract_quote { + my ($head, $tail) = @_; + my ($extracted, $remainder, $prefix) + = extract_delimited($tail, q{'"}, qr{[^'"]*}msx, q{}); + if ($extracted) { + return ($head . $prefix . $extracted, $remainder); + } + else { + my ($quote) = $tail =~ $RE{QUOTE}; + return ($head . $tail, q{}, $quote); + } +} + +# Study statements and put attributes into array $statements +sub _process { + my ($statement, $ctx, $state) = @_; + my $name; + + # End Interface + if ($state->{in_interface}) { + if ($statement->{value} =~ qr{\A\s*end\s*interface\b}imsx) { + $state->{in_interface} = 0; + } + return; + } + + # End Program Unit + if (@{$state->{stack}} && $statement->{value} =~ qr{\A\s*end\b}imsx) { + my ($end, $type, $symbol) = lc($statement->{value}) =~ $RE{UNIT_END}; + if (!$end) { + return; + } + my ($top_type, $top_symbol) = @{$state->{stack}->[-1]}; + if (!$type + || $top_type eq $type && (!$symbol || $top_symbol eq $symbol)) + { + pop(@{$state->{stack}}); + if ($state->{in_contains} && !@{$state->{stack}}) { + $state->{in_contains} = 0; + } + if (!$state->{in_contains}) { + $statement->{name} = $top_type; + $statement->{symbol} = $top_symbol; + $statement->{type} = 'end'; + return $statement; + } + } + return; + } + + # Interface/Contains + ($name) = $statement->{value} =~ qr{\A\s*(contains|interface)\b}imsx; + if ($name) { + $state->{'in_' . lc($name)} = 1; + return; + } + + # Program Unit + my ($type, $symbol, @tokens) = _process_prog_unit($statement->{value}); + if ($type) { + push(@{$state->{stack}}, [$type, $symbol]); + if ($state->{in_contains}) { + return; + } + $statement->{name} = lc($type); + $statement->{type} = 'signature'; + $statement->{symbol} = lc($symbol); + $ctx->{signature_token_set_of}{$symbol} + = {map { (lc($_) => 1) } @tokens}; + return $statement; + } + if ($state->{in_contains}) { + return; + } + + # Use + if ($statement->{value} =~ qr{\A\s*(use)\b}imsx) { + $statement->{name} = 'use'; + $statement->{type} = 'use'; + return $statement; + } + + # Type Declarations + ($name) = $statement->{value} =~ $RE{TYPE_SPEC}; + if ($name) { + $name =~ s{\s}{}gmsx; + $statement->{name} = lc($name); + $statement->{type} = 'type'; + return $statement; + } + + # Attribute Statements + ($name) = $statement->{value} =~ $RE{TYPE_ATTR}; + if ($name) { + $statement->{name} = $name; + $statement->{type} = 'attr'; + return $statement; + } +} + +# Parse a statement for program unit header. Returns a list containing the type, +# the symbol and the signature tokens of the program unit. +sub _process_prog_unit { + my ($string) = @_; + my ($type, $symbol, @args) = (q{}, q{}); + # Is it a blockdata, module or program? + ($type, $symbol) = $string =~ $RE{UNIT_BASE}; + if ($type) { + $type = lc($type); + $type =~ s{\s*}{}gmsx; + return ($type, $symbol); + } + # Remove the attribute and type declaration of a procedure + $string =~ s/$RE{UNIT_ATTR}/$1/; + my ($match) = $string =~ $RE{UNIT_SPEC}; + if ($match) { + $string = $match; + extract_bracketed($string); + } + # Is it a function or subroutine? + ($type, $symbol) = lc($string) =~ $RE{UNIT_CALL}; + if (!$type) { + return; + } + my $extracted = extract_bracketed($string, q{()}, qr{[^(]*}msx); + + # Get signature tokens from SUBROUTINE/FUNCTION + if ($extracted) { + $extracted =~ s{\s}{}gmsx; + @args = split(q{,}, substr($extracted, 1, length($extracted) - 2)); + if ($type eq 'function') { + my $result = extract_bracketed($string, q{()}, qr{[^(]*}msx); + if ($result) { + $result =~ s{\A\(\s*(.*?)\s*\)\z}{$1}msx; # remove braces + push(@args, $result); + } + else { + push(@args, $symbol); + } + } + } + return (lc($type), lc($symbol), map { lc($_) } @args); +} + +# Reduces the list of statements to contain only the interface block. +sub _reduce_to_interface { + my ($ctx) = @_; + my (%token_set, @interface_statements); +STATEMENT: + for my $statement (reverse(@{$ctx->{statements}})) { + if ($statement->{type} eq 'end' + && grep { $_ eq $statement->{name} } qw{subroutine function}) + { + push(@interface_statements, $statement); + %token_set + = %{$ctx->{signature_token_set_of}{$statement->{symbol}}}; + next STATEMENT; + } + if ($statement->{type} eq 'signature' + && grep { $_ eq $statement->{name} } qw{subroutine function}) + { + push(@interface_statements, $statement); + %token_set = (); + next STATEMENT; + } + if ($statement->{type} eq 'use') { + my ($head, $tail) + = split(qr{\s*:\s*}msx, lc($statement->{value}), 2); + if ($tail) { + my @imports = map { [split(qr{\s*=>\s*}msx, $_, 2)] } + split(qr{\s*,\s*}msx, $tail); + my @useful_imports + = grep { exists($token_set{$_->[0]}) } @imports; + if (!@useful_imports) { + next STATEMENT; + } + if (@imports != @useful_imports) { + my @token_strings + = map { $_->[0] . ($_->[1] ? ' => ' . $_->[1] : q{}) } + @useful_imports; + my ($last, @rest) = reverse(@token_strings); + my @token_lines + = (reverse(map { $_ . q{,&} } @rest), $last); + push( + @interface_statements, + { lines => [ + sprintf("%s:&\n", $head), + (map { sprintf(" & %s\n", $_) } @token_lines), + ] + }, + ); + next STATEMENT; + } + } + push(@interface_statements, $statement); + next STATEMENT; + } + if ($statement->{type} eq 'attr') { + my ($spec, @tokens) = ($statement->{value} =~ /$RE{NAME_COMP}/g); + if (grep { exists($token_set{$_}) } @tokens) { + for my $token (@tokens) { + $token_set{$token} = 1; + } + push(@interface_statements, $statement); + next STATEMENT; + } + } + if ($statement->{type} eq 'type') { + my ($variable_string, $spec_string) + = reverse(split('::', lc($statement->{value}), 2)); + if ($spec_string) { + $spec_string =~ s{$RE{NAME_LEAD}}{}msx; + } + else { + # The first expression in the statement is the type + attrib + $variable_string =~ s{$RE{NAME_LEAD}}{}msx; + $spec_string = extract_bracketed($variable_string, '()', + qr{[\s\*]*}msx); + } + # Useful tokens are those that comes after a comma + my $tail = q{,} . lc($variable_string); + my @tokens; + while ($tail) { + if ($tail =~ qr{\A\s*['"]}msx) { + extract_delimited($tail, q{'"}, qr{\A[^'"]*}msx, q{}); + } + elsif ($tail =~ qr{\A\s*\(}msx) { + extract_bracketed($tail, '()', qr{\A[^(]*}msx); + } + else { + my $token; + ($token, $tail) = $tail =~ $RE{NAME_LIST}; + if ($token && $token_set{$token}) { + @tokens = ($variable_string =~ /$RE{NAME_COMP}/g); + $tail = q{}; + } + } + } + if (@tokens && $spec_string) { + my @spec_tokens = (lc($spec_string) =~ /$RE{NAME_COMP}/g); + push( + @tokens, + ( grep { !exists($TYPE_DECL_KEYWORD_SET{$_}) } + @spec_tokens + ), + ); + } + if (grep { exists($token_set{$_}) } @tokens) { + for my $token (@tokens) { + $token_set{$token} = 1; + } + push(@interface_statements, $statement); + next STATEMENT; + } + } + } + if (!@interface_statements) { + return []; + } + [ {lines => ["interface\n"]}, + reverse(@interface_statements), + {lines => ["end interface\n"]}, + ]; +} + +# Processes and returns the line of the statement. +sub _present_line { + my ($statement) = @_; + map { + s{\s+}{ }gmsx; # collapse multiple spaces + s{\s+\z}{\n}msx; # remove trailing spaces + $_; + } @{$statement->{lines}}; +} + +# ------------------------------------------------------------------------------ +1; +__END__ + +=head1 NAME + +Fcm::Build::Fortran + +=head1 SYNOPSIS + + use Fcm::Build::Fortran; + my $fortran_util = Fcm::Build::Fortran->new(); + open(my($handle), '<', $path_to_a_fortran_source_file); + print($fortran_util->extract_interface($handle)); # prints interface + close($handle); + +=head1 DESCRIPTION + +A class to analyse Fortran source. Currently, it has a single method to extract +the calling interfaces of top level subroutines and functions in a Fortran +source. + +=head1 METHODS + +=over 4 + +=item $class->new() + +Creates and returns an instance of this class. + +=item $instance->extract_interface($handle) + +Extracts the calling interfaces of top level subroutines and functions in a +Fortran source that can be read from $handle. Returns an interface block as a +list of lines. + +=back + +=head1 ACKNOWLEDGEMENT + +This module is inspired by the logic developed by the European Centre +for Medium-Range Weather Forecasts (ECMWF). + +=head1 COPYRIGHT + +(C) Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/BuildSrc.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/BuildSrc.pm new file mode 100644 index 0000000..7a2a0a7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/BuildSrc.pm @@ -0,0 +1,1499 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::BuildSrc +# +# DESCRIPTION +# This is a class to group functionalities of source in a build. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +package Fcm::BuildSrc; +use base qw{Fcm::Base}; + +use Carp qw{croak}; +use Cwd qw{cwd}; +use Fcm::Build::Fortran; +use Fcm::CfgFile; +use Fcm::CfgLine; +use Fcm::Config; +use Fcm::Timer qw{timestamp_command}; +use Fcm::Util qw{find_file_in_path run_command}; +use File::Basename qw{basename dirname}; +use File::Spec; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'children', # list of children packages + 'is_updated', # is this source (or its associated settings) updated? + 'mtime', # modification time of src + 'ppmtime', # modification time of ppsrc + 'ppsrc', # full path of the pre-processed source + 'pkgname', # package name of the source + 'progname', # program unit name in the source + 'src', # full path of the source + 'type', # type of the source +); + +# List of hash property methods for this class +my @hash_properties = ( + 'dep', # dependencies + 'ppdep', # pre-process dependencies + 'rules', # make rules +); + +# Error message formats +my %ERR_MESS_OF = ( + CHDIR => '%s: cannot change directory (%s), abort', + OPEN => '%s: cannot open (%s), abort', + CLOSE_PIPE => '%s: failed (%d), abort', +); + +# Event message formats and levels +my %EVENT_SETTING_OF = ( + CHDIR => ['%s: change directory' , 2], + F_INTERFACE_NONE => ['%s: Fortran interface generation is off', 3], + GET_DEPENDENCY => ['%s: %d line(s), %d auto dependency(ies)', 3], +); + +my %RE_OF = ( + F_PREFIX => qr{ + (?: + (?:ELEMENTAL|PURE(?:\s+RECURSIVE)?|RECURSIVE(?:\s+PURE)?) + \s+ + )? + }imsx, + F_SPEC => qr{ + (?: + (?:CHARACTER|COMPLEX|DOUBLE\s*PRECISION|INTEGER|LOGICAL|REAL|TYPE) + (?: \s* \( .+ \) | \s* \* \d+ \s*)?? + \s+ + )? + }imsx, +); + +{ + # Returns a singleton instance of Fcm::Build::Fortran. + my $FORTRAN_UTIL; + sub _get_fortran_util { + $FORTRAN_UTIL ||= Fcm::Build::Fortran->new(); + return $FORTRAN_UTIL; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::BuildSrc->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::BuildSrc class. See +# above for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my ($class, %args) = @_; + my $self = bless(Fcm::Base->new(%args), $class); + for my $key (@scalar_properties, @hash_properties) { + $self->{$key} + = exists($args{uc($key)}) ? $args{uc($key)} + : undef + ; + } + $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + + if ($name eq 'ppsrc') { + $self->ppmtime (undef); + + } elsif ($name eq 'src') { + $self->mtime (undef); + } + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'children') { + # Reference to an empty array + $self->{$name} = []; + + } elsif ($name =~ /^(?:is_cur|pkgname|ppsrc|src)$/) { + # Empty string + $self->{$name} = ''; + + } elsif ($name eq 'mtime') { + # Modification time + $self->{$name} = (stat $self->src)[9] if $self->src; + + } elsif ($name eq 'ppmtime') { + # Modification time + $self->{$name} = (stat $self->ppsrc)[9] if $self->ppsrc; + + } elsif ($name eq 'type') { + # Attempt to get the type if src is set + $self->{$name} = $self->get_type if $self->src; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + if (not defined $self->{$name}) { + if ($name eq 'rules') { + $self->{$name} = $self->get_rules; + + } else { + $self->{$name} = {}; + } + } + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# This method returns/sets property X, all derived from src, where X is: +# base - (read-only) basename of src +# dir - (read-only) dirname of src +# ext - (read-only) file extension of src +# root - (read-only) basename of src without the file extension +# ------------------------------------------------------------------------------ + +sub base { + return &basename ($_[0]->src); +} + +# ------------------------------------------------------------------------------ + +sub dir { + return &dirname ($_[0]->src); +} + +# ------------------------------------------------------------------------------ + +sub ext { + return substr $_[0]->base, length ($_[0]->root); +} + +# ------------------------------------------------------------------------------ + +sub root { + (my $root = $_[0]->base) =~ s/\.\w+$//; + return $root; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# This method returns/sets property X, all derived from ppsrc, where X is: +# ppbase - (read-only) basename of ppsrc +# ppdir - (read-only) dirname of ppsrc +# ppext - (read-only) file extension of ppsrc +# pproot - (read-only) basename of ppsrc without the file extension +# ------------------------------------------------------------------------------ + +sub ppbase { + return &basename ($_[0]->ppsrc); +} + +# ------------------------------------------------------------------------------ + +sub ppdir { + return &dirname ($_[0]->ppsrc); +} + +# ------------------------------------------------------------------------------ + +sub ppext { + return substr $_[0]->ppbase, length ($_[0]->pproot); +} + +# ------------------------------------------------------------------------------ + +sub pproot { + (my $root = $_[0]->ppbase) =~ s/\.\w+$//; + return $root; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# +# DESCRIPTION +# This method returns/sets property X, derived from src or ppsrc, where X is: +# curbase - (read-only) basename of cursrc +# curdir - (read-only) dirname of cursrc +# curext - (read-only) file extension of cursrc +# curmtime - (read-only) modification time of cursrc +# curroot - (read-only) basename of cursrc without the file extension +# cursrc - ppsrc or src +# ------------------------------------------------------------------------------ + +for my $name (qw/base dir ext mtime root src/) { + no strict 'refs'; + + my $subname = 'cur' . $name; + + *$subname = sub { + my $self = shift; + my $method = $self->ppsrc ? 'pp' . $name : $name; + return $self->$method (@_); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $base = $obj->X (); +# +# DESCRIPTION +# This method returns a basename X for the source, where X is: +# donebase - "done" file name +# etcbase - target for copying data files +# exebase - executable name for source containing a main program +# interfacebase - Fortran interface file name +# libbase - library file name +# objbase - object name for source containing compilable source +# If the source file contains a compilable procedure, this method returns +# the name of the object file. +# ------------------------------------------------------------------------------ + +sub donebase { + my $self = shift; + + my $return; + if ($self->is_type_all ('SOURCE')) { + if ($self->objbase and not $self->is_type_all ('PROGRAM')) { + $return = ($self->progname ? $self->progname : lc ($self->curroot)) . + $self->setting (qw/OUTFILE_EXT DONE/); + } + + } elsif ($self->is_type_all ('INCLUDE')) { + $return = $self->curbase . $self->setting (qw/OUTFILE_EXT IDONE/); + } + + return $return; +} + +# ------------------------------------------------------------------------------ + +sub etcbase { + my $self = shift; + + my $return = @{ $self->children } + ? $self->pkgname . $self->setting (qw/OUTFILE_EXT ETC/) + : undef; + + return $return; +} + +# ------------------------------------------------------------------------------ + +sub exebase { + my $self = shift; + + my $return; + if ($self->objbase and $self->is_type_all ('PROGRAM')) { + if ($self->setting ('BLD_EXE_NAME', $self->curroot)) { + $return = $self->setting ('BLD_EXE_NAME', $self->curroot); + + } else { + $return = $self->curroot . $self->setting (qw/OUTFILE_EXT EXE/); + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ + +sub interfacebase { + my $self = shift(); + if ( + defined($self->get_setting(qw/TOOL GENINTERFACE/)) + && uc($self->get_setting(qw/TOOL GENINTERFACE/)) ne 'NONE' + && $self->progname() + && $self->is_type_all(qw/SOURCE/) + && $self->is_type_any(qw/FORTRAN9X FPP9X/) + && !$self->is_type_any(qw/PROGRAM MODULE BLOCKDATA/) + ) { + my $flag = lc($self->get_setting(qw/TOOL INTERFACE/)); + my $ext = $self->setting(qw/OUTFILE_EXT INTERFACE/); + + return (($flag eq 'program' ? $self->progname() : $self->curroot()) . $ext); + } + return; +} + +# ------------------------------------------------------------------------------ + +sub objbase { + my $self = shift; + + my $return; + + if ($self->is_type_all ('SOURCE')) { + my $ext = $self->setting (qw/OUTFILE_EXT OBJ/); + + if ($self->is_type_any (qw/FORTRAN FPP/)) { + $return = lc ($self->progname) . $ext if $self->progname; + + } else { + $return = lc ($self->curroot) . $ext; + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->flagsbase ($flag, [$index,]); +# +# DESCRIPTION +# This method returns the property flagsbase (derived from pkgname) the base +# name of the flags-file (to indicate changes in a particular build tool) for +# $flag, which can have the value: +# *FLAGS - compiler flags flags-file +# *PPKEYS - pre-processor keys (i.e. macro definitions) flags-file +# LD - linker flags-file +# LDFLAGS - linker flags flags-file +# If $index is set, the $index'th element in pkgnames is used for the package +# name. +# ------------------------------------------------------------------------------ + +sub flagsbase { + my ($self, $flag, $index) = @_; + + (my $pkg = $index ? $self->pkgnames->[$index] : $self->pkgname) =~ s/\.\w+$//; + + if ($self->is_type_all ('SOURCE')) { + if ($flag eq 'FLAGS' or $flag eq 'PPKEYS' and $self->lang) { + my %tool_src = %{ $self->setting ('TOOL_SRC') }; + $flag = $tool_src{$self->lang}{$flag} ? $tool_src{$self->lang}{$flag} : ''; + } + } + + if ($flag) { + return join ('__', ($flag, $pkg ? $pkg : ())) . + $self->setting (qw/OUTFILE_EXT FLAGS/); + + } else { + return undef; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->libbase ([$prefix], [$suffix]); +# +# DESCRIPTION +# This method returns the property libbase (derived from pkgname) the base +# name of the library archive. $prefix and $suffix defaults to 'lib' and '.a' +# respectively. +# ------------------------------------------------------------------------------ + +sub libbase { + my ($self, $prefix, $suffix) = @_; + $prefix ||= 'lib'; + $suffix ||= $self->setting(qw/OUTFILE_EXT LIB/); + if ($self->src()) { # applies to directories only + return; + } + my $name = $self->setting('BLD_LIB', $self->pkgname()); + if (!defined($name)) { + $name = $self->pkgname(); + } + $prefix . $name . $suffix; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->lang ([$setting]); +# +# DESCRIPTION +# This method returns the property lang (derived from type) the programming +# language name if type matches one supported in the TOOL_SRC setting. If +# $setting is specified, use $setting instead of TOOL_SRC. +# ------------------------------------------------------------------------------ + +sub lang { + my ($self, $setting) = @_; + + my @keys = keys %{ $self->setting ($setting ? $setting : 'TOOL_SRC') }; + + my $return = undef; + for my $key (@keys) { + next unless $self->is_type_all ('SOURCE', $key); + $return = $key; + last; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->pkgnames; +# +# DESCRIPTION +# This method returns a list of container packages, derived from pkgname: +# ------------------------------------------------------------------------------ + +sub pkgnames { + my $self = shift; + + my $return = []; + if ($self->pkgname) { + my @names = split (/__/, $self->pkgname); + + for my $i (0 .. $#names) { + push @$return, join ('__', (@names[0 .. $i])); + } + + unshift @$return, ''; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %dep = %{$obj->get_dep()}; +# %dep = %{$obj->get_dep($flag)}; +# +# DESCRIPTION +# This method scans the current source file for dependencies and returns the +# dependency hash (keys = dependencies, values = dependency types). If $flag +# is specified, the config setting for $flag is used to determine the types of +# types. Otherwise, those specified in 'BLD_TYPE_DEP' is used. +# ------------------------------------------------------------------------------ + +sub get_dep { + my ($self, $flag) = @_; + # Work out list of exclude for this file, using its sub-package name + my %EXCLUDE_SET = map {($_, 1)} @{$self->get_setting('BLD_DEP_EXCL')}; + # Determine what dependencies are supported by this known type + my %DEP_TYPE_OF = %{$self->setting($flag ? $flag : 'BLD_TYPE_DEP')}; + my %PATTERN_OF = %{$self->setting('BLD_DEP_PATTERN')}; + my @dep_types = (); + if (!$self->get_setting('BLD_DEP_N')) { + DEP_TYPE: + while (my ($key, $dep_type_string) = each(%DEP_TYPE_OF)) { + # Check if current file is a type of file requiring dependency scan + if (!$self->is_type_all($key)) { + next DEP_TYPE; + } + # Get list of dependency type for this file + for my $dep_type (split(/$Fcm::Config::DELIMITER/, $dep_type_string)) { + if (exists($PATTERN_OF{$dep_type}) && !exists($EXCLUDE_SET{$dep_type})) { + push(@dep_types, $dep_type); + } + } + } + } + + # Automatic dependencies + my %dep_of; + my $can_get_symbol # Also scan for program unit name in Fortran source + = !$flag + && $self->is_type_all('SOURCE') + && $self->is_type_any(qw/FPP FORTRAN/) + ; + my $has_read_file; + if ($can_get_symbol || @dep_types) { + my $handle = _open($self->cursrc()); + LINE: + while (my $line = readline($handle)) { + chomp($line); + if ($line =~ qr{\A \s* \z}msx) { # empty lines + next LINE; + } + if ($can_get_symbol) { + my $symbol = _get_dep_symbol($line); + if ($symbol) { + $self->progname($symbol); + $can_get_symbol = 0; + next LINE; + } + } + DEP_TYPE: + for my $dep_type (@dep_types) { + my ($match) = $line =~ /$PATTERN_OF{$dep_type}/i; + if (!$match) { + next DEP_TYPE; + } + # $match may contain multiple items delimited by space + for my $item (split(qr{\s+}msx, $match)) { + my $key = uc($dep_type . $Fcm::Config::DELIMITER . $item); + if (!exists($EXCLUDE_SET{$key})) { + $dep_of{$item} = $dep_type; + } + } + next LINE; + } + } + $self->_event('GET_DEPENDENCY', $self->pkgname(), $., scalar(keys(%dep_of))); + close($handle); + $has_read_file = 1; + } + + # Manual dependencies + my $manual_deps_ref + = $self->setting('BLD_DEP' . ($flag ? '_PP' : ''), $self->pkgname()); + if (defined($manual_deps_ref)) { + for (@{$manual_deps_ref}) { + my ($dep_type, $item) = split(/$Fcm::Config::DELIMITER/, $_, 2); + $dep_of{$item} = $dep_type; + } + } + + return ($has_read_file, \%dep_of); +} + +# Returns, if possible, the program unit declared in the $line. +sub _get_dep_symbol { + my $line = shift(); + for my $pattern ( + qr{\A \s* $RE_OF{F_PREFIX} SUBROUTINE \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* MODULE (?!\s+PROCEDURE) \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* PROGRAM \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* $RE_OF{F_PREFIX} $RE_OF{F_SPEC} FUNCTION \s+ ([A-Za-z]\w*)}imsx, + qr{\A \s* BLOCK\s*DATA \s+ ([A-Za-z]\w*)}imsx, + ) { + my ($match) = $line =~ $pattern; + if ($match) { + return lc($match); + } + } + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @out = @{ $obj->get_fortran_interface () }; +# +# DESCRIPTION +# This method invokes the Fortran interface block generator to generate +# an interface block for the current source file. It returns a reference to +# an array containing the lines of the interface block. +# ------------------------------------------------------------------------------ + +sub get_fortran_interface { + my $self = shift(); + my %ACTION_OF = ( + q{} => \&_get_fortran_interface_by_internal_code, + f90aib => \&_get_fortran_interface_by_f90aib, + none => sub {$self->_event('F_INTERFACE_NONE', $self->root()); []}, + ); + my $key = lc($self->get_setting(qw/TOOL GENINTERFACE/)); + if (!$key || !exists($ACTION_OF{$key})) { + $key = q{}; + } + $ACTION_OF{$key}->($self->cursrc()); +} + +# Generates Fortran interface block using "f90aib". +sub _get_fortran_interface_by_f90aib { + my $path = shift(); + my $command = sprintf(q{f90aib <'%s' 2>'%s'}, $path, File::Spec->devnull()); + my $pipe = _open($command, '-|'); + my @lines = readline($pipe); + close($pipe) || croak($ERR_MESS_OF{CLOSE_PIPE}, $command, $?); + \@lines; +} + +# Generates Fortran interface block using internal code. +sub _get_fortran_interface_by_internal_code { + my $path = shift(); + my $handle = _open($path); + my @lines = _get_fortran_util()->extract_interface($handle); + close($handle); + \@lines; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @out = @{ $obj->get_pre_process () }; +# +# DESCRIPTION +# This method invokes the pre-processor on the source file and returns a +# reference to an array containing the lines of the pre-processed source on +# success. +# ------------------------------------------------------------------------------ + +sub get_pre_process { + my $self = shift; + + # Supported source files + my $lang = $self->lang ('TOOL_SRC_PP'); + return unless $lang; + + # List of include directories + my @inc = @{ $self->setting (qw/PATH INC/) }; + + # Build the pre-processor command according to file type + my %tool = %{ $self->setting ('TOOL') }; + my %tool_src_pp = %{ $self->setting ('TOOL_SRC_PP', $lang) }; + + # The pre-processor command and its options + my @command = ($tool{$tool_src_pp{COMMAND}}); + my @ppflags = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{FLAGS}); + + # List of defined macros, add "-D" in front of each macro + my @ppkeys = split /\s+/, $self->get_setting ('TOOL', $tool_src_pp{PPKEYS}); + @ppkeys = map {($tool{$tool_src_pp{DEFINE}} . $_)} @ppkeys; + + # Add "-I" in front of each include directories + @inc = map {($tool{$tool_src_pp{INCLUDE}} . $_)} @inc; + + push @command, (@ppflags, @ppkeys, @inc, $self->base); + + # Change to container directory of source file + my $old_cwd = $self->_chdir($self->dir()); + + # Execute the command, getting the output lines + my $verbose = $self->verbose; + my @outlines = &run_command ( + \@command, METHOD => 'qx', PRINT => $verbose > 1, TIME => $verbose > 2, + ); + + # Change back to original directory + $self->_chdir($old_cwd); + + return \@outlines; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rules = %{ $self->get_rules }; +# +# DESCRIPTION +# This method returns a reference to a hash in the following format: +# $rules = { +# target => {ACTION => action, DEP => [dependencies], ...}, +# ... => {...}, +# }; +# where the 1st rank keys are the available targets for building this source +# file, the second rank keys are ACTION and DEP. The value of ACTION is the +# action for building the target, which can be "COMPILE", "LOAD", "TOUCH", +# "CP" or "AR". The value of DEP is a refernce to an array containing a list +# of dependencies suitable for insertion into the Makefile. +# ------------------------------------------------------------------------------ + +sub get_rules { + my $self = shift; + + my $rules; + my %outfile_ext = %{ $self->setting ('OUTFILE_EXT') }; + + if ($self->is_type_all (qw/SOURCE/)) { + # Source file + # -------------------------------------------------------------------------- + # Determine whether the language of the source file is supported + my %tool_src = %{ $self->setting ('TOOL_SRC') }; + + return () unless $self->lang; + + # Compile object + # -------------------------------------------------------------------------- + if ($self->objbase) { + # Depends on the source file + my @dep = ($self->rule_src); + + # Depends on the compiler flags flags-file + my @flags; + push @flags, ('FLAGS' ) + if $self->flagsbase ('FLAGS' ); + push @flags, ('PPKEYS') + if $self->flagsbase ('PPKEYS') and not $self->ppsrc; + + push @dep, $self->flagsbase ($_) for (@flags); + + # Source file dependencies + for my $name (sort keys %{ $self->dep }) { + # A Fortran 9X module, lower case object file name + if ($self->dep ($name) eq 'USE') { + (my $root = $name) =~ s/\.\w+$//; + push @dep, lc ($root) . $outfile_ext{OBJ}; + + # An include file + } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) { + push @dep, $name; + } + } + + $rules->{$self->objbase} = {ACTION => 'COMPILE', DEP => \@dep}; + + # Touch flags-files + # ------------------------------------------------------------------------ + for my $flag (@flags) { + next unless $self->flagsbase ($flag); + + $rules->{$self->flagsbase ($flag)} = { + ACTION => 'TOUCH', + DEP => [ + $self->flagsbase ($tool_src{$self->lang}{$flag}, -2), + ], + DEST => '$(FCM_FLAGSDIR)', + }; + } + } + + if ($self->exebase) { + # Link into an executable + # ------------------------------------------------------------------------ + my @dep = (); + push @dep, $self->objbase if $self->objbase; + push @dep, $self->flagsbase ('LD' ) if $self->flagsbase ('LD' ); + push @dep, $self->flagsbase ('LDFLAGS') if $self->flagsbase ('LDFLAGS'); + + # Depends on BLOCKDATA program units, for Fortran programs + my %blockdata = %{ $self->setting ('BLD_BLOCKDATA') }; + my @blkobj = (); + + if ($self->is_type_any (qw/FPP FORTRAN/) and keys %blockdata) { + # List of BLOCKDATA object files + if (exists $blockdata{$self->exebase}) { + @blkobj = split /\s+/, $blockdata{$self->exebase}; + + } elsif (exists $blockdata{''}) { + @blkobj = split /\s+/, $blockdata{''}; + } + + for my $name (@blkobj) { + (my $root = $name) =~ s/\.\w+$//; + $name = $root . $outfile_ext{OBJ}; + push @dep, $root . $outfile_ext{DONE}; + } + } + + # Extra executable dependencies + my %exe_dep = %{ $self->setting ('BLD_DEP_EXE') }; + if (keys %exe_dep) { + my @exe_deps; + if (exists $exe_dep{$self->exebase}) { + @exe_deps = split /\s+/, $exe_dep{$self->exebase}; + + } elsif (exists $exe_dep{''}) { + @exe_deps = $exe_dep{''} ? split (/\s+/, $exe_dep{''}) : (''); + } + + my $pattern = '\\' . $outfile_ext{OBJ} . '$'; + + for my $name (@exe_deps) { + if ($name =~ /$pattern/) { + # Extra dependency is an object + (my $root = $name) =~ s/\.\w+$//; + push @dep, $root . $outfile_ext{DONE}; + + } else { + # Extra dependency is a sub-package + my $var; + if ($self->setting ('FCM_PCK_OBJECTS', $name)) { + # sub-package name contains unusual characters + $var = $self->setting ('FCM_PCK_OBJECTS', $name); + + } else { + # sub-package name contains normal characters + $var = $name ? join ('__', ('OBJECTS', $name)) : 'OBJECTS'; + } + + push @dep, '$(' . $var . ')'; + } + } + } + + # Source file dependencies + for my $name (sort keys %{ $self->dep }) { + (my $root = $name) =~ s/\.\w+$//; + + # Lowercase name for object dependency + $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/; + + # Select "done" file extension + if ($self->dep ($name) =~ /^(?:INC|H)$/) { + push @dep, $name . $outfile_ext{IDONE}; + + } else { + push @dep, $root . $outfile_ext{DONE}; + } + } + + $rules->{$self->exebase} = { + ACTION => 'LOAD', DEP => \@dep, BLOCKDATA => \@blkobj, + }; + + # Touch Linker flags-file + # ------------------------------------------------------------------------ + for my $flag (qw/LD LDFLAGS/) { + $rules->{$self->flagsbase ($flag)} = { + ACTION => 'TOUCH', + DEP => [$self->flagsbase ($flag, -2)], + DEST => '$(FCM_FLAGSDIR)', + }; + } + + } + + if ($self->donebase) { + # Touch done file + # ------------------------------------------------------------------------ + my @dep = ($self->objbase); + + for my $name (sort keys %{ $self->dep }) { + (my $root = $name) =~ s/\.\w+$//; + + # Lowercase name for object dependency + $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/; + + # Select "done" file extension + if ($self->dep ($name) =~ /^(?:INC|H)$/) { + push @dep, $name . $outfile_ext{IDONE}; + + } else { + push @dep, $root . $outfile_ext{DONE}; + } + } + + $rules->{$self->donebase} = { + ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)', + }; + } + + if ($self->interfacebase) { + # Interface target + # ------------------------------------------------------------------------ + # Source file dependencies + my @dep = (); + for my $name (sort keys %{ $self->dep }) { + # Depends on Fortran 9X modules + push @dep, lc ($name) . $outfile_ext{OBJ} + if $self->dep ($name) eq 'USE'; + } + + $rules->{$self->interfacebase} = {ACTION => '', DEP => \@dep}; + } + + } elsif ($self->is_type_all ('INCLUDE')) { + # Copy include target + # -------------------------------------------------------------------------- + my @dep = ($self->rule_src); + + for my $name (sort keys %{ $self->dep }) { + # A Fortran 9X module, lower case object file name + if ($self->dep ($name) eq 'USE') { + (my $root = $name) =~ s/\.\w+$//; + push @dep, lc ($root) . $outfile_ext{OBJ}; + + # An include file + } elsif ($self->dep ($name) =~ /^(?:INC|H|INTERFACE)$/) { + push @dep, $name; + } + } + + $rules->{$self->curbase} = { + ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_INCDIR)', + }; + + # Touch IDONE file + # -------------------------------------------------------------------------- + if ($self->donebase) { + my @dep = ($self->rule_src); + + for my $name (sort keys %{ $self->dep }) { + (my $root = $name) =~ s/\.\w+$//; + + # Lowercase name for object dependency + $root = lc ($root) unless $self->dep ($name) =~ /^(?:INC|H)$/; + + # Select "done" file extension + if ($self->dep ($name) =~ /^(?:INC|H)$/) { + push @dep, $name . $outfile_ext{IDONE}; + + } else { + push @dep, $root . $outfile_ext{DONE}; + } + } + + $rules->{$self->donebase} = { + ACTION => 'TOUCH', DEP => \@dep, DEST => '$(FCM_DONEDIR)', + }; + } + + } elsif ($self->is_type_any (qw/EXE SCRIPT/)) { + # Copy executable file + # -------------------------------------------------------------------------- + my @dep = ($self->rule_src); + + # Depends on dummy copy file, if file is an "always build type" + push @dep, $self->setting (qw/BLD_CPDUMMY/) + if $self->is_type_any (split ( + /$Fcm::Config::DELIMITER_LIST/, $self->setting ('BLD_TYPE_ALWAYS_BUILD') + )); + + # Depends on other executable files + for my $name (sort keys %{ $self->dep }) { + push @dep, $name if $self->dep ($name) eq 'EXE'; + } + + $rules->{$self->curbase} = { + ACTION => 'CP', DEP => \@dep, DEST => '$(FCM_BINDIR)', + }; + + } elsif (@{ $self->children }) { + # Targets for top level and package flags files and dummy dependencies + # -------------------------------------------------------------------------- + my %tool_src = %{ $self->setting ('TOOL_SRC') }; + my %flags_tool = (LD => '', LDFLAGS => ''); + + for my $key (keys %tool_src) { + $flags_tool{$tool_src{$key}{FLAGS}} = $tool_src{$key}{COMMAND} + if exists $tool_src{$key}{FLAGS}; + + $flags_tool{$tool_src{$key}{PPKEYS}} = '' + if exists $tool_src{$key}{PPKEYS}; + } + + for my $name (sort keys %flags_tool) { + my @dep = $self->pkgname eq '' ? () : $self->flagsbase ($name, -2); + push @dep, $self->flagsbase ($flags_tool{$name}) + if $self->pkgname eq '' and $flags_tool{$name}; + + $rules->{$self->flagsbase ($flags_tool{$name})} = { + ACTION => 'TOUCH', + DEST => '$(FCM_FLAGSDIR)', + } if $self->pkgname eq '' and $flags_tool{$name}; + + $rules->{$self->flagsbase ($name)} = { + ACTION => 'TOUCH', + DEP => \@dep, + DEST => '$(FCM_FLAGSDIR)', + }; + } + + # Package object and library + # -------------------------------------------------------------------------- + { + my @dep; + # Add objects from children + for my $child (sort {$a->pkgname cmp $b->pkgname} @{ $self->children }) { + push @dep, $child->rule_obj_var (1) + if $child->libbase and $child->rules ($child->libbase); + push @dep, $child->objbase + if $child->cursrc and $child->objbase and + not $child->is_type_any (qw/PROGRAM BLOCKDATA/); + } + + if (@dep) { + $rules->{$self->libbase} = {ACTION => 'AR', DEP => \@dep}; + } + } + + # Package data files + # -------------------------------------------------------------------------- + { + my @dep; + for my $child (@{ $self->children }) { + push @dep, $child->rule_src if $child->src and not $child->type; + } + + if (@dep) { + push @dep, $self->setting (qw/BLD_CPDUMMY/); + $rules->{$self->etcbase} = { + ACTION => 'CP_DATA', DEP => \@dep, DEST => '$(FCM_ETCDIR)', + }; + } + } + } + + return $rules; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->get_setting ($setting[, @prefix]); +# +# DESCRIPTION +# This method gets the correct $setting for the current source by following +# its package name. If @prefix is set, get the setting with the given prefix. +# ------------------------------------------------------------------------------ + +sub get_setting { + my ($self, $setting, @prefix) = @_; + + my $val; + for my $name (reverse @{ $self->pkgnames }) { + my @names = split /__/, $name; + $val = $self->setting ($setting, join ('__', (@prefix, @names))); + + $val = $self->setting ($setting, join ('__', (@prefix, @names))) + if (not defined $val) and @names and $names[-1] =~ s/\.[^\.]+$//; + last if defined $val; + } + + return $val; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $type = $self->get_type(); +# +# DESCRIPTION +# This method determines whether the source is a type known to the +# build system. If so, it returns the type flags delimited by "::". +# ------------------------------------------------------------------------------ + +sub get_type { + my $self = shift(); + my @IGNORE_LIST + = split(/$Fcm::Config::DELIMITER_LIST/, $self->setting('INFILE_IGNORE')); + if (grep {$self->curbase() eq $_} @IGNORE_LIST) { + return q{}; + } + # User defined + my $type = $self->setting('BLD_TYPE', $self->pkgname()); + # Extension + if (!defined($type)) { + my $ext = $self->curext() ? substr($self->curext(), 1) : q{}; + $type = $self->setting('INFILE_EXT', $ext); + } + # Pattern of name + if (!defined($type)) { + my %NAME_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_PAT')}; + PATTERN: + while (my ($pattern, $value) = each(%NAME_PATTERN_TO_TYPE_HASH)) { + if ($self->curbase() =~ $pattern) { + $type = $value; + last PATTERN; + } + } + } + # Pattern of #! line + if (!defined($type) && -s $self->cursrc() && -T _) { + my $handle = _open($self->cursrc()); + my $line = readline($handle); + close($handle); + my %SHEBANG_PATTERN_TO_TYPE_HASH = %{$self->setting('INFILE_TXT')}; + PATTERN: + while (my ($pattern, $value) = each(%SHEBANG_PATTERN_TO_TYPE_HASH)) { + if ($line =~ qr{^\#!.*$pattern}msx) { + $type = $value; + last PATTERN; + } + } + } + if (!$type) { + return $type; + } + # Extra type information for selected file types + my %EXTRA_FOR = ( + qr{\b (?:FORTRAN|FPP) \b}msx => \&_get_type_extra_for_fortran, + qr{\b C \b}msx => \&_get_type_extra_for_c, + ); + EXTRA: + while (my ($key, $code_ref) = each(%EXTRA_FOR)) { + if ($type =~ $key) { + my $handle = _open($self->cursrc()); + LINE: + while (my $line = readline($handle)) { + my $extra = $code_ref->($line); + if ($extra) { + $type .= $Fcm::Config::DELIMITER . $extra; + last LINE; + } + } + close($handle); + last EXTRA; + } + } + return $type; +} + +sub _get_type_extra_for_fortran { + my ($match) = $_[0] =~ qr{\A \s* (PROGRAM|MODULE|BLOCK\s*DATA) \b}imsx; + if (!$match) { + return; + } + $match =~ s{\s}{}g; + uc($match) +} + +sub _get_type_extra_for_c { + ($_[0] =~ qr{int\s+main\s*\(}msx) ? 'PROGRAM' : undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->is_in_package ($name); +# +# DESCRIPTION +# This method returns true if current package is in the package $name. +# ------------------------------------------------------------------------------ + +sub is_in_package { + my ($self, $name) = @_; + + my $return = 0; + for (@{ $self->pkgnames }) { + next unless /^$name(?:\.\w+)?$/; + $return = 1; + last; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->is_type_all ($arg, ...); +# $flag = $obj->is_type_any ($arg, ...); +# +# DESCRIPTION +# This method returns a flag for the following: +# is_type_all - does type match all of the arguments? +# is_type_any - does type match any of the arguments? +# ------------------------------------------------------------------------------ + +for my $name ('all', 'any') { + no strict 'refs'; + + my $subname = 'is_type_' . $name; + + *$subname = sub { + my ($self, @intypes) = @_; + + my $rc = 0; + if ($self->type) { + my %types = map {($_, 1)} split /$Fcm::Config::DELIMITER/, $self->type; + + for my $intype (@intypes) { + $rc = exists $types{$intype}; + last if ($name eq 'all' and not $rc) or ($name eq 'any' and $rc); + } + } + + return $rc; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->rule_obj_var ([$read]); +# +# DESCRIPTION +# This method returns a string containing the make rule object variable for +# the current package. If $read is set, return $($string) +# ------------------------------------------------------------------------------ + +sub rule_obj_var { + my ($self, $read) = @_; + + my $return; + if ($self->setting ('FCM_PCK_OBJECTS', $self->pkgname)) { + # Package name registered in unusual list + $return = $self->setting ('FCM_PCK_OBJECTS', $self->pkgname); + + } else { + # Package name not registered in unusual list + $return = $self->pkgname + ? join ('__', ('OBJECTS', $self->pkgname)) : 'OBJECTS'; + } + + $return = $read ? '$(' . $return . ')' : $return; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->rule_src (); +# +# DESCRIPTION +# This method returns a string containing the location of the source file +# relative to the build root. This string will be suitable for use in a +# "Make" rule file for FCM. +# ------------------------------------------------------------------------------ + +sub rule_src { + my $self = shift; + + my $return = $self->cursrc; + LABEL: for my $name (qw/SRC PPSRC/) { + for my $i (0 .. @{ $self->setting ('PATH', $name) } - 1) { + my $dir = $self->setting ('PATH', $name)->[$i]; + next unless index ($self->cursrc, $dir) == 0; + + $return = File::Spec->catfile ( + '$(FCM_' . $name . 'DIR' . ($i ? $i : '') . ')', + File::Spec->abs2rel ($self->cursrc, $dir), + ); + last LABEL; + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->write_lib_dep_excl (); +# +# DESCRIPTION +# This method writes a set of exclude dependency configurations for the +# library of this package. +# ------------------------------------------------------------------------------ + +sub write_lib_dep_excl { + my $self = shift(); + if (!find_file_in_path($self->libbase(), $self->setting(qw/PATH LIB/))) { + return 0; + } + + my $ETC_DIR = $self->setting(qw/PATH ETC/)->[0]; + my $CFG_EXT = $self->setting(qw/OUTFILE_EXT CFG/); + my $LABEL_OF_EXCL_DEP = $self->cfglabel('BLD_DEP_EXCL'); + my @SETTINGS = ( + #dependency #source file type list #dependency name function + ['H' , [qw{INCLUDE CPP }], sub {$_[0]->base()} ], + ['INTERFACE', [qw{INCLUDE INTERFACE }], sub {$_[0]->base()} ], + ['INC' , [qw{INCLUDE }], sub {$_[0]->base()} ], + ['USE' , [qw{SOURCE FORTRAN MODULE}], sub {$_[0]->root()} ], + ['INTERFACE', [qw{SOURCE FORTRAN }], sub {$_[0]->interfacebase()}], + ['OBJ' , [qw{SOURCE }], sub {$_[0]->root()} ], + ); + + my $cfg = Fcm::CfgFile->new(); + my @stack = ($self); + NODE: + while (my $node = pop(@stack)) { + # Is a directory + if (@{$node->children()}) { + push(@stack, reverse(@{$node->children()})); + next NODE; + } + # Is a typed file + if ( + $node->cursrc() + && $node->type() + && !$node->is_type_any(qw{PROGRAM BLOCKDATA}) + ) { + for (@SETTINGS) { + my ($key, $type_list_ref, $name_func_ref) = @{$_}; + my $name = $name_func_ref->($node); + if ($name && $node->is_type_all(@{$type_list_ref})) { + push( + @{$cfg->lines()}, + Fcm::CfgLine->new( + label => $LABEL_OF_EXCL_DEP, + value => $key . $Fcm::Config::DELIMITER . $name, + ), + ); + next NODE; + } + } + } + } + + # Write to configuration file + $cfg->print_cfg( + File::Spec->catfile($ETC_DIR, $self->libbase('lib', $CFG_EXT)), + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->write_rules (); +# +# DESCRIPTION +# This method returns a string containing the "Make" rules for building the +# source file. +# ------------------------------------------------------------------------------ + +sub write_rules { + my $self = shift; + my $mk = ''; + + for my $target (sort keys %{ $self->rules }) { + my $rule = $self->rules ($target); + next unless defined ($rule->{ACTION}); + + if ($rule->{ACTION} eq 'AR') { + my $var = $self->rule_obj_var; + $mk .= ($var eq 'OBJECTS' ? 'export ' : '') . $var . ' ='; + $mk .= ' ' . join (' ', @{ $rule->{DEP} }); + $mk .= "\n\n"; + } + + $mk .= $target . ':'; + + if ($rule->{ACTION} eq 'AR') { + $mk .= ' ' . $self->rule_obj_var (1); + + } else { + for my $dep (@{ $rule->{DEP} }) { + $mk .= ' ' . $dep; + } + } + + $mk .= "\n"; + + if (exists $rule->{ACTION}) { + if ($rule->{ACTION} eq 'AR') { + $mk .= "\t" . 'fcm_internal archive $@ $^' . "\n"; + + } elsif ($rule->{ACTION} eq 'CP') { + $mk .= "\t" . 'cp $< ' . $rule->{DEST} . "\n"; + $mk .= "\t" . 'chmod u+w ' . + File::Spec->catfile ($rule->{DEST}, '$@') . "\n"; + + } elsif ($rule->{ACTION} eq 'CP_DATA') { + $mk .= "\t" . 'cp $^ ' . $rule->{DEST} . "\n"; + $mk .= "\t" . 'touch ' . + File::Spec->catfile ($rule->{DEST}, '$@') . "\n"; + + } elsif ($rule->{ACTION} eq 'COMPILE') { + if ($self->lang) { + $mk .= "\t" . 'fcm_internal compile:' . substr ($self->lang, 0, 1) . + ' ' . $self->pkgnames->[-2] . ' $< $@'; + $mk .= ' 1' if ($self->flagsbase ('PPKEYS') and not $self->ppsrc); + $mk .= "\n"; + } + + } elsif ($rule->{ACTION} eq 'LOAD') { + if ($self->lang) { + $mk .= "\t" . 'fcm_internal load:' . substr ($self->lang, 0, 1) . + ' ' . $self->pkgnames->[-2] . ' $< $@'; + $mk .= ' ' . join (' ', @{ $rule->{BLOCKDATA} }) + if @{ $rule->{BLOCKDATA} }; + $mk .= "\n"; + } + + } elsif ($rule->{ACTION} eq 'TOUCH') { + $mk .= "\t" . 'touch ' . + File::Spec->catfile ($rule->{DEST}, '$@') . "\n"; + } + } + + $mk .= "\n"; + } + + return $mk; +} + +# Wraps "chdir". Returns old directory. +sub _chdir { + my ($self, $dir) = @_; + my $old_cwd = cwd(); + $self->_event('CHDIR', $dir); + chdir($dir) || croak(sprintf($ERR_MESS_OF{CHDIR}, $dir)); + $old_cwd; +} + +# Wraps an event. +sub _event { + my ($self, $key, @args) = @_; + my ($format, $level) = @{$EVENT_SETTING_OF{$key}}; + $level ||= 1; + if ($self->verbose() >= $level) { + printf($format . ".\n", @args); + } +} + +# Wraps "open". +sub _open { + my ($path, $mode) = @_; + $mode ||= '<'; + open(my $handle, $mode, $path) || croak(sprintf($ERR_MESS_OF{OPEN}, $path, $!)); + $handle; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/BuildTask.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/BuildTask.pm new file mode 100644 index 0000000..b5f886e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/BuildTask.pm @@ -0,0 +1,340 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::BuildTask +# +# DESCRIPTION +# This class hosts information of a build task in the FCM build system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::BuildTask; +@ISA = qw(Fcm::Base); + +# Standard pragma +use strict; +use warnings; + +# Standard modules +use Carp; +use File::Compare; +use File::Copy; +use File::Basename; +use File::Path; +use File::Spec::Functions; + +# FCM component modules +use Fcm::Base; +use Fcm::Timer; +use Fcm::Util; + +# List of property methods for this class +my @scalar_properties = ( + 'actiontype', # type of action + 'dependency', # list of dependencies for this target + 'srcfile', # reference to input Fcm::BuildSrc instance + 'output', # output file + 'outputmtime', # output file modification time + 'target', # target name for this task + 'targetpath', # search path for the target +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::BuildTask->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::BuildTask class. See +# above for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + bless $self, $class; + + for my $name (@scalar_properties) { + $self->{$name} = exists $args{uc ($name)} ? $args{uc ($name)} : undef; + } + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + + if ($name eq 'output') { + $self->{outputmtime} = $_[0] ? (stat $_[0]) [9] : undef; + } + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'dependency' or $name eq 'targetpath') { + # Reference to an array + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->action (TASKLIST => \%tasklist); +# +# DESCRIPTION +# This method performs the task action and sets the output accordingly. The +# argument TASKLIST must be a reference to a hash containing the other tasks +# of the build, which this task may depend on. The keys of the hash must the +# name of the target names of the tasks, and the values of the hash must be +# the references to the corresponding Fcm::BuildTask instances. The method +# returns true if the task has been performed to create a new version of the +# target. +# ------------------------------------------------------------------------------ + +sub action { + my $self = shift; + my %args = @_; + my $tasklist = exists $args{TASKLIST} ? $args{TASKLIST} : {}; + + return unless $self->actiontype; + + my $uptodate = 1; + my $dep_uptodate = 1; + + # Check if dependencies are up to date + # ---------------------------------------------------------------------------- + for my $depend (@{ $self->dependency }) { + if (exists $tasklist->{$depend}) { + if (not $tasklist->{$depend}->output) { + # Dependency task output is not set, performs its task action + if ($tasklist->{$depend}->action (TASKLIST => $tasklist)) { + $uptodate = 0; + $dep_uptodate = 0; + } + } + + } elsif ($self->verbose > 1) { + w_report 'Warning: Task for "', $depend, + '" does not exist, may be required by ', $self->target; + } + } + + # Check if the target exists in the search path + # ---------------------------------------------------------------------------- + if (@{ $self->targetpath }) { + my $output = find_file_in_path ($self->target, $self->targetpath); + $self->output ($output) if $output; + } + + # Target is out of date if it does not exist + if ($uptodate) { + $uptodate = 0 if not $self->output; + } + + # Check if current target is older than its dependencies + # ---------------------------------------------------------------------------- + if ($uptodate) { + for my $depend (@{ $self->dependency }) { + next unless exists $tasklist->{$depend}; + + if ($tasklist->{$depend}->outputmtime > $self->outputmtime) { + $uptodate = 0; + $dep_uptodate = 0; + } + } + + if ($uptodate and ref $self->srcfile) { + $uptodate = 0 if $self->srcfile->mtime > $self->outputmtime; + } + } + + if ($uptodate) { + # Current target and its dependencies are up to date + # -------------------------------------------------------------------------- + if ($self->actiontype eq 'PP') { + # "done" file up to date, set name of pre-processed source file + # ------------------------------------------------------------------------ + my $base = $self->srcfile->root . lc ($self->srcfile->ext); + my @pknames = split '__', (@{ $self->srcfile->pkgnames })[-2]; + my @path = map { + catfile ($_, @pknames); + } @{ $self->setting (qw/PATH PPSRC/) }; + my $oldfile = find_file_in_path ($base, \@path); + $self->srcfile->ppsrc ($oldfile); + } + + } else { + # Perform action is not up to date + # -------------------------------------------------------------------------- + # (For GENINTERFACE and PP, perform action if "done" file not up to date) + my $new_output = @{ $self->targetpath } + ? catfile ($self->targetpath->[0], $self->target) + : $self->target; + + # Create destination container directory if necessary + my $destdir = dirname $new_output; + + if (not -d $destdir) { + print 'Make directory: ', $destdir, "\n" if $self->verbose > 2; + mkpath $destdir; + } + + # List of actions + if ($self->actiontype eq 'UPDATE') { + # Action is UPDATE: Update file + # ------------------------------------------------------------------------ + print 'Update: ', $new_output, "\n" if $self->verbose > 2; + touch_file $new_output + or croak 'Unable to update "', $new_output, '", abort'; + $self->output ($new_output); + + } elsif ($self->actiontype eq 'COPY') { + # Action is COPY: copy file to destination if necessary + # ------------------------------------------------------------------------ + my $copy_required = ($dep_uptodate and $self->output and -r $self->output) + ? compare ($self->output, $self->srcfile->src) + : 1; + + if ($copy_required) { + # Set up copy command + my $srcfile = $self->srcfile->src; + my $destfile = catfile ($destdir, basename($srcfile)); + print 'Copy: ', $srcfile, "\n", ' to: ', $destfile, "\n" + if $self->verbose > 2; + © ($srcfile, $destfile) + or die $srcfile, ': copy to ', $destfile, ' failed (', $!, '), abort'; + chmod (((stat ($srcfile))[2] & 07777), $destfile); + + $self->output ($new_output); + + } else { + $uptodate = 1; + } + + } elsif ($self->actiontype eq 'PP' or $self->actiontype eq 'GENINTERFACE') { + # Action is PP or GENINTERFACE: process file + # ------------------------------------------------------------------------ + my ($newlines, $base, @path); + + if ($self->actiontype eq 'PP') { + # Invoke the pre-processor on the source file + # ---------------------------------------------------------------------- + # Get lines in the pre-processed source + $newlines = $self->srcfile->get_pre_process; + $base = $self->srcfile->root . lc ($self->srcfile->ext); + + # Get search path for the existing pre-processed file + my @pknames = split '__', (@{ $self->srcfile->pkgnames })[-2]; + @path = map { + catfile ($_, @pknames); + } @{ $self->setting (qw/PATH PPSRC/) }; + + } else { # if ($self->actiontype eq 'GENINTERFACE') + # Invoke the interface generator + # ---------------------------------------------------------------------- + # Get new interface lines + $newlines = $self->srcfile->get_fortran_interface; + + # Get search path for the existing interface file + $base = $self->srcfile->interfacebase; + @path = @{ $self->setting (qw/PATH INC/) }, + } + + + # If pre-processed or interface file exists, + # compare its content with new lines to see if it has been updated + my $update_required = 1; + my $oldfile = find_file_in_path ($base, \@path); + + if ($oldfile and -r $oldfile) { + # Read old file + open FILE, '<', $oldfile; + my @oldlines = readline 'FILE'; + close FILE; + + # Compare old contents and new contents + if (@oldlines eq @$newlines) { + $update_required = grep { + $oldlines[$_] ne $newlines->[$_]; + } (0 .. $#oldlines); + } + } + + if ($update_required) { + # Update the pre-processed source or interface file + # ---------------------------------------------------------------------- + # Determine container directory of the pre-processed or interface file + my $newfile = @path ? catfile ($path[0], $base) : $base; + + # Create the container directory if necessary + if (not -d $path[0]) { + print 'Make directory: ', $path[0], "\n" + if $self->verbose > 1; + mkpath $path[0]; + } + + # Update the pre-processor or interface file + open FILE, '>', $newfile + or croak 'Cannot write to "', $newfile, '" (', $!, '), abort'; + print FILE @$newlines; + close FILE + or croak 'Cannot write to "', $newfile, '" (', $!, '), abort'; + print 'Generated: ', $newfile, "\n" if $self->verbose > 1; + + # Set the name of the pre-processed file + $self->srcfile->ppsrc ($newfile) if $self->actiontype eq 'PP'; + + } else { + # Content in pre-processed source or interface file is up to date + # ---------------------------------------------------------------------- + $uptodate = 1; + + # Set the name of the pre-processed file + $self->srcfile->ppsrc ($oldfile) if $self->actiontype eq 'PP'; + } + + # Update the "done" file + print 'Update: ', $new_output, "\n" if $self->verbose > 2; + touch_file $new_output + or croak 'Unable to update "', $new_output, '", abort'; + $self->output ($new_output); + + } else { + carp 'Action type "', $self->actiontype, "' not supported"; + } + } + + return not $uptodate; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI.pm new file mode 100644 index 0000000..8e592d7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI.pm @@ -0,0 +1,172 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI; + +use Carp qw{croak}; +use Fcm::CLI::Config; +use Fcm::CLI::Exception; +use Fcm::Util::ClassLoader; +use File::Basename qw{basename}; +use Getopt::Long qw{GetOptions}; +use Scalar::Util qw{blessed}; + +################################################################################ +# Invokes the FCM command line interface +sub invoke { + local(@ARGV) = @ARGV; + my $config = Fcm::CLI::Config->instance(); + my $subcommand_name = @ARGV ? shift(@ARGV) : q{}; + my $subcommand = $config->get_subcommand_of($subcommand_name); + eval { + if (!$subcommand) { + croak(Fcm::CLI::Exception->new({message => 'unknown command'})); + } + my ($opts_ref, $args_ref, $is_help) = _parse_argv_using($subcommand); + my ($invoker_class, $invoker); + if ($is_help) { + $invoker_class + = _load_invoker_class_of($config->get_subcommand_of(q{})); + $invoker = $invoker_class->new({ + command => $subcommand_name, + arguments => [$subcommand_name], + }); + } + else { + $invoker_class = _load_invoker_class_of($subcommand); + $invoker = $invoker_class->new({ + command => $subcommand_name, + options => $opts_ref, + arguments => $args_ref, + ( + $subcommand->get_invoker_config() + ? %{$subcommand->get_invoker_config()} + : () + ), + }); + } + $invoker->invoke(); + }; + if ($@) { + if (Fcm::CLI::Exception->caught($@)) { + die(sprintf( + qq{%s%s: %s\nType "%s help%s" for usage\n}, + basename($0), + ($subcommand_name ? qq{ $subcommand_name} : q{}), + $@->get_message(), + basename($0), + defined($subcommand) ? qq{ $subcommand_name} : q{}, + )); + } + else { + die($@); + } + } +} + +################################################################################ +# Parses options in @ARGV using the options settings of a subcommand +sub _parse_argv_using { + my ($subcommand) = @_; + my %options = (); + my $is_help = undef; + if (($subcommand->get_options())) { + my $problem = q{}; + local($SIG{__WARN__}) = sub { + ($problem) = @_; + }; + my $success = GetOptions( + \%options, + (map {$_->get_arg_for_getopt_long()} ($subcommand->get_options())), + ); + if (!$success) { + croak(Fcm::CLI::Exception->new({message => sprintf( + "option parse failed: %s", $problem, + )})); + } + + OPTION: + for my $option ($subcommand->get_options()) { + if (!exists($options{$option->get_name()})) { + next OPTION; + } + if ($option->is_help()) { + $is_help = 1; + } + if ( + $option->has_arg() == $option->ARRAY_ARG + && $option->get_delimiter() + ) { + $options{$option->get_name()} = [split( + $option->get_delimiter(), + join( + $option->get_delimiter(), + @{$options{$option->get_name()}}, + ), + )]; + } + } + } + return (\%options, [@ARGV], $is_help); +} + +################################################################################ +# Loads and returns the invoker class of a subcommand +sub _load_invoker_class_of { + my ($subcommand) = @_; + my $invoker_class + = $subcommand->get_invoker_class() ? $subcommand->get_invoker_class() + : 'Fcm::CLI::Invoker' + ; + return Fcm::Util::ClassLoader::load($invoker_class); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI + +=head1 SYNOPSIS + + use Fcm::CLI + Fcm::CLI::invoke(); + +=head1 DESCRIPTION + +Invokes the FCM command line interface. + +=head1 FUNCTIONS + +=over 4 + +=item invoke() + +Invokes the FCM command line interface. + +=back + +=head1 TO DO + +Move option/argument parsing to L? + +Use an OO interface? + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Config.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Config.pm new file mode 100644 index 0000000..7813cdd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Config.pm @@ -0,0 +1,133 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Config; + +use Fcm::CLI::Config::Default; +use List::Util qw{first}; +use Scalar::Util qw{blessed}; + +my $INSTANCE; + +################################################################################ +# Class method: returns an instance of this class +sub instance { + my ($class, $args_ref) = @_; + if ($args_ref || !$INSTANCE) { + $INSTANCE = bless({ + core_subcommands => [@Fcm::CLI::Config::Default::CORE_SUBCOMMANDS], + vc_subcommands => [@Fcm::CLI::Config::Default::VC_SUBCOMMANDS], + (defined($args_ref) ? %{$args_ref} : ()), + }, $class); + } + return $INSTANCE; +} + +################################################################################ +# Returns a subcommand matching $key +sub get_subcommand_of { + my ($self, $key) = @_; + if (blessed($key) && $key->isa('Fcm::CLI::Subcommand')) { + return first {"$_" eq "$key"} ($self->get_subcommands()); + } + else { + return first {$_->has_a_name($key)} ($self->get_subcommands()); + } +} + +################################################################################ +# Returns the subcommands +sub get_subcommands { + my ($self) = @_; + my @return = ($self->get_core_subcommands(), $self->get_vc_subcommands()); + return (wantarray() ? @return : \@return); +} + +################################################################################ +# Returns the core subcommands +sub get_core_subcommands { + my ($self) = @_; + return ( + wantarray() ? @{$self->{core_subcommands}} : $self->{core_subcommands} + ); +} + +################################################################################ +# Returns the subcommands that are relevant only with a VC system +sub get_vc_subcommands { + my ($self) = @_; + return (wantarray() ? @{$self->{vc_subcommands}} : $self->{vc_subcommands}); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Config + +=head1 SYNOPSIS + + use Fcm::CLI::Config; + $cli_config = Fcm::CLI::Config->instance(); + $subcommand = $cli_config->get_subcommand_of($key); + @subcommands = $cli_config->get_subcommands(); + @core_subcommands = $cli_config->get_core_subcommands(); + @vc_subcommands = $cli_config->get_vc_subcommands(); + +=head1 DESCRIPTION + +This class provides the configuration of the FCM command line interface. + +=head1 METHODS + +=over 4 + +=item instance($arg_ref) + +Returns an instance of this class. + +Creates the instance on first call, or replaces it with a new one if $args_ref +is defined in subsequent call. $args_ref should be a reference to a hash. The +hash can contain I and I. Each of these +settings should point to an array reference containing L +objects. If the setting is unspecified, it uses the default from +L. + +=item get_subcommand_of($key) + +Returns a L object matching the +search $key. Returns undef if there is no match. + +=item get_subcommands() + +Short-hand for: + ($self->get_core_subcommands(), $self->get_vc_subcommands()) + +=item get_core_subcommands() + +Returns the core subcommands. + +=item get_vc_subcommands() + +Returns the subcommands that are relevant only in the presence of a VC system. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Config/Default.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Config/Default.pm new file mode 100644 index 0000000..526f54d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Config/Default.pm @@ -0,0 +1,412 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Config::Default; + +use Fcm::CLI::Option; +use Fcm::CLI::Subcommand; + +my %DESCRIPTION_OF = ( + # -------------------------------------------------------------------------- + BROWSER => <<'END_DESCRIPTION', +If TARGET is specified, it must be a FCM URL keyword, a Subversion URL or the +path to a local working copy. If not specified, the current working directory +is assumed to be a working copy. If the --browser option is specified, the +specified web browser command is used to launch the repository browser. +Otherwise, it attempts to use the default browser from the configuration +setting. +END_DESCRIPTION + # -------------------------------------------------------------------------- + BUILD => <<'END_DESCRIPTION', +The path to a CFGFILE may be provided. Otherwise, the build system searches the +default locations for a bld cfg file. + +If no option is specified, the options "-s 5 -t all -j 1 -v 1" are assumed. + +If the option for full build is specified, the sub-directories created by +previous builds will be removed, so that the current build can start cleanly. + +The -s option can be used to limit the actions performed by the build system up +to a named stage. The stages are: + "1", "s" or "setup" - stage 1, setup + "2", "pp" or "pre_process" - stage 2, pre-process + "3", "gd" or "generate_dependency" - stage 3, generate dependency + "4", "gi" or "generate_interface" - stage 4, generate Fortran 9X interface + "5", "m", "make" - stage 5, make + +If a colon separated list of targets is specified using the -t option, the +default targets specified in the configuration file will not be used. + +If archive mode is switched on, build sub-directories that are only used in the +build process will be archived to TAR files. The default is off. + +If specified, the verbose level must be an integer greater than 0. Verbose +level 0 is the quiet mode. Increasing the verbose level will increase the +amount of diagnostic output. + +When a build is invoked, it sets up a lock file in the build root directory. +The lock is normally removed at the end of the build. While the lock file is in +place, the build commands invoked in the same root directory will fail. If +you need to bypass this check for whatever reason, you can invoke the build +system with the --ignore-lock option. +END_DESCRIPTION + # -------------------------------------------------------------------------- + CFG_PRINTER => <<'END_DESCRIPTION', +If no option is specified, the output will be sent to standard output. +END_DESCRIPTION + # -------------------------------------------------------------------------- + EXTRACT => <<'END_DESCRIPTION', +The path to a CFG file may be provided. Otherwise, the extract system searches +the default locations for an ext cfg file. + +If no option is specified, the system will attempt an incremental extract where +appropriate. + +If specified, the verbose level must be an integer greater than 0. Verbose +level 0 is the quiet mode. Increasing the verbose level will increase the +amount of diagnostic output. + +When an extract is invoked, it sets up a lock file in the extract destination +root directory. The lock is normally removed at the end of the extract. While +the lock file is in place, other extract commands invoked in the same +destination root directory will fail. If you need to bypass this check for +whatever reason, you can invoke the extract system with the --ignore-lock +option. +END_DESCRIPTION + # -------------------------------------------------------------------------- + EXTRACT_CONFIG_COMPARATOR => <<'END_DESCRIPTION', +Compares the extract configurations of two similar extract configuration files +CFGFILE1 and CFGFILE2. + +In normal mode with verbosity level 2 or above, displays the change log of each +revision. + +In wiki mode, print revision tables in wiki format. The argument to the --wiki +option must be the Subversion URL or FCM URL keyword of a FCM project +associated with the intended Trac system. The --verbose option has no effect +in wiki mode. +END_DESCRIPTION + # -------------------------------------------------------------------------- + GUI => <<'END_DESCRIPTION', +The optional argument PATH modifies the initial working directory of the GUI. +END_DESCRIPTION + # -------------------------------------------------------------------------- + KEYWORD => <<'END_DESCRIPTION', +If no argument is specified, prints registered location keywords. Otherwise, +prints the implied location keywords and revision keywords for the specified +target. +END_DESCRIPTION +); + +my %OPTION_OF = ( + ARCHIVE => Fcm::CLI::Option->new({ + name => 'archive', + letter => 'a', + description => 'archives sub-directories on success', + }), + + BROWSER => Fcm::CLI::Option->new({ + name => 'browser', + letter => 'b', + description => 'specifies the web browser command', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + CLEAN => Fcm::CLI::Option->new({ + name => 'clean', + description => 'cleans the destination', + }), + + FULL => Fcm::CLI::Option->new({ + name => 'full', + letter => 'f', + description => 'runs in full mode', + }), + + HELP => Fcm::CLI::Option->new({ + name => 'help', + letter => 'h', + description => 'prints help', + is_help => 1, + }), + + IGNORE_LOCK => Fcm::CLI::Option->new({ + name => 'ignore-lock', + description => 'ignores lock file', + }), + + JOBS => Fcm::CLI::Option->new({ + name => 'jobs', + letter => 'j', + description => 'number of parallel jobs', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + OUTPUT => Fcm::CLI::Option->new({ + name => 'output', + letter => 'o', + description => 'sends output to the specified file', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + STAGE => Fcm::CLI::Option->new({ + name => 'stage', + letter => 's', + description => 'runs command up to a named stage', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + TARGETS => Fcm::CLI::Option->new({ + name => 'targets', + letter => 't', + delimiter => ':', + description => 'list of build targets, delimited by (:)', + has_arg => Fcm::CLI::Option->ARRAY_ARG, + }), + + VERBOSITY => Fcm::CLI::Option->new({ + name => 'verbose', + letter => 'v', + description => 'verbose level', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), + + WIKI => Fcm::CLI::Option->new({ + name => 'wiki', + letter => 'w', + description => 'print revision tables in wiki format', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + }), +); + +my %SUBCOMMAND_OF = ( + BRANCH => Fcm::CLI::Subcommand->new({ + names => ['branch', 'br'], + synopsis => 'branch utilities', + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), + + BROWSER => Fcm::CLI::Subcommand->new({ + names => ['trac', 'www'], + synopsis => 'invokes the browser for a version controlled target', + usage => '[OPTIONS...] [TARGET]', + description => $DESCRIPTION_OF{BROWSER}, + invoker_class => 'Fcm::CLI::Invoker::Browser', + options => [ + $OPTION_OF{BROWSER}, + $OPTION_OF{HELP}, + ], + }), + + BUILD => Fcm::CLI::Subcommand->new({ + names => ['build', 'bld'], + synopsis => 'invokes the build system', + usage => '[OPTIONS...] [CFGFILE]', + description => $DESCRIPTION_OF{BUILD}, + invoker_class => 'Fcm::CLI::Invoker::ConfigSystem', + invoker_config => { + impl_class => 'Fcm::Build', + cli2invoke_key_map => { + 'archive' => 'ARCHIVE', + 'clean' => 'CLEAN', + 'full' => 'FULL', + 'ignore-lock' => 'IGNORE_LOCK', + 'jobs' => 'JOBS', + 'stage' => 'STAGE', + 'targets' => 'TARGETS', + }, + }, + options => [ + $OPTION_OF{ARCHIVE}, + $OPTION_OF{CLEAN}, + $OPTION_OF{FULL}, + $OPTION_OF{HELP}, + $OPTION_OF{IGNORE_LOCK}, + $OPTION_OF{JOBS}, + $OPTION_OF{STAGE}, + $OPTION_OF{TARGETS}, + $OPTION_OF{VERBOSITY}, + ], + }), + + CFG_PRINTER => Fcm::CLI::Subcommand->new({ + names => ['cfg'], + synopsis => 'invokes the CFG file pretty printer', + usage => '[OPTIONS...] [CFGFILE]', + description => $DESCRIPTION_OF{CFG_PRINTER}, + invoker_class => 'Fcm::CLI::Invoker::CfgPrinter', + options => [ + $OPTION_OF{HELP}, + $OPTION_OF{OUTPUT}, + ], + }), + + CM => Fcm::CLI::Subcommand->new({ + names => [qw{ + add + blame praise annotate ann + cat + checkout co + cleanup + commit ci + copy cp + delete del remove rm + diff di + export + import + info + list ls + lock + log + merge + mkdir + move mv rename ren + propdel pdel pd + propedit pedit pe + propget pget pg + proplist plist pl + propset pset ps + resolved + revert + status stat st + switch sw + unlock + update up + }], + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), + + CONFLICTS => Fcm::CLI::Subcommand->new({ + names => ['conflicts', 'cf'], + synopsis => 'resolves conflicts in your working copy', + usage => '[PATH]', + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), + + EXTRACT => Fcm::CLI::Subcommand->new({ + names => ['extract', 'ext'], + synopsis => 'invokes the extract system', + usage => '[OPTIONS...] [CFGFILE]', + description => $DESCRIPTION_OF{EXTRACT}, + invoker_class => 'Fcm::CLI::Invoker::ConfigSystem', + invoker_config => { + impl_class => 'Fcm::Extract', + cli2invoke_key_map => { + 'clean' => 'CLEAN', + 'full' => 'FULL', + 'ignore-lock' => 'IGNORE_LOCK', + }, + }, + options => [ + $OPTION_OF{CLEAN}, + $OPTION_OF{FULL}, + $OPTION_OF{HELP}, + $OPTION_OF{IGNORE_LOCK}, + $OPTION_OF{VERBOSITY}, + ], + }), + + EXTRACT_CONFIG_COMPARATOR => Fcm::CLI::Subcommand->new({ + names => ['cmp-ext-cfg'], + synopsis => 'invokes the extract configuration files comparator', + usage => '[OPTIONS...] CFGFILE1 CFGFILE2', + description => $DESCRIPTION_OF{EXTRACT_CONFIG_COMPARATOR}, + invoker_class => 'Fcm::CLI::Invoker::ExtractConfigComparator', + options => [ + $OPTION_OF{HELP}, + $OPTION_OF{VERBOSITY}, + $OPTION_OF{WIKI}, + ], + }), + + GUI => Fcm::CLI::Subcommand->new({ + names => ['gui'], + synopsis => 'invokes the GUI wrapper for code management commands', + usage => '[PATH]', + description => $DESCRIPTION_OF{GUI}, + invoker_class => 'Fcm::CLI::Invoker::GUI', + }), + + HELP => Fcm::CLI::Subcommand->new({ + names => ['help', q{?}, q{}], + synopsis => 'displays the usage of this program or its subcommands', + usage => '[SUBCOMMAND]', + description => q{}, + invoker_class => 'Fcm::CLI::Invoker::Help', + options => [$OPTION_OF{HELP}], + }), + + KEYWORD => Fcm::CLI::Subcommand->new({ + names => ['keyword-print', 'kp'], + synopsis => 'prints registered location and/or revision keywords', + usage => '[TARGET]', + description => $DESCRIPTION_OF{KEYWORD}, + invoker_class => 'Fcm::CLI::Invoker::KeywordPrinter', + options => [$OPTION_OF{HELP}], + }), + + MKPATCH => Fcm::CLI::Subcommand->new({ + names => ['mkpatch'], + synopsis => 'creates patches from specified revisions of a URL', + usage => '[OPTIONS] URL [OUTDIR]', + invoker_class => 'Fcm::CLI::Invoker::CM', + is_vc => 1, + }), +); + +our @CORE_SUBCOMMANDS = ( + $SUBCOMMAND_OF{HELP}, + $SUBCOMMAND_OF{BUILD}, + $SUBCOMMAND_OF{CFG_PRINTER}, +); + +our @VC_SUBCOMMANDS = ( + $SUBCOMMAND_OF{BRANCH}, + $SUBCOMMAND_OF{BROWSER}, + $SUBCOMMAND_OF{CONFLICTS}, + $SUBCOMMAND_OF{EXTRACT}, + $SUBCOMMAND_OF{EXTRACT_CONFIG_COMPARATOR}, + $SUBCOMMAND_OF{GUI}, + $SUBCOMMAND_OF{KEYWORD}, + $SUBCOMMAND_OF{MKPATCH}, + $SUBCOMMAND_OF{CM}, +); + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Config::Default + +=head1 SYNOPSIS + + use Fcm::CLI::Config::Default; + @core_subcommands = @Fcm::CLI::Config::Default::CORE_SUBCOMMANDS; + @vc_subcommands = @Fcm::CLI::Config::Default::VC_SUBCOMMANDS; + +=head1 DESCRIPTION + +This module stores the default configuration of the FCM command line interface. +It should only be used by L. + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Exception.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Exception.pm new file mode 100644 index 0000000..db1dbc7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Exception.pm @@ -0,0 +1,42 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Exception; +use base qw{Fcm::Exception}; + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Exception + +=head1 SYNOPSIS + + use Carp qw{croak}; + use Fcm::CLI::Exception; + croak(Fcm::CLI::Exception->new({message => 'something is wrong'})); + +=head1 DESCRIPTION + +This class extends L. This exception is thrown +on errors associated with the command line interface. + +=head1 METHODS + +See L for a list of methods. + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker.pm new file mode 100644 index 0000000..a83238a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker.pm @@ -0,0 +1,136 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker; + +use Carp qw{croak}; +use Fcm::CLI::Exception; + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns the name of the (sub)command as given by the user +sub get_command { + my ($self) = @_; + return $self->{command}; +} + +################################################################################ +# Returns a reference to a hash containing the options +sub get_options { + my ($self) = @_; + return (wantarray() ? %{$self->{options}} : $self->{options}); +} + +################################################################################ +# Returns a reference to an array containing the arguments +sub get_arguments { + my ($self) = @_; + return (wantarray() ? @{$self->{arguments}} : $self->{arguments}); +} + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my $message = "command not implemented\n"; + $message .= sprintf("opts:"); + for my $key (sort keys(%{$self->get_options()})) { + my $value = $self->get_options()->{$key}; + $message .= sprintf( + " [%s=%s]", + $key, + ($value && ref($value) eq 'ARRAY' ? join(q{, }, @{$value}) : $value) + ); + } + $message .= sprintf("\n"); + $message .= sprintf("args: [%s]\n", join(q{] [}, $self->get_arguments())); + croak(Fcm::CLI::Exception->new({message => $message})); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker; + $invoker = Fcm::CLI::Invoker->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This is the base class for an invoker of a FCM sub-system from the CLI. +Sub-classes should override the invoke() method. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor. It accepts a hash reference as an argument. The element I +should be set to the actual (sub)command as specified by the user. The element +I should be a reference to a hash containing the specified command line +options. The element I should be a reference to an array containing +the remaining command line arguments. + +=item get_command() + +Returns the actual (sub)command as specified by the user. + +=item get_options() + +Returns a hash containing the specified command line options. In scalar context, +returns a reference to the hash. + +=item get_arguments() + +Returns an array containing the (remaining) command line arguments. In scalar +context, returns a reference to the array. + +=item invoke() + +Sub-classes should override this method. Calling the method in this base +class causes the system to croak() with a +L. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The C croak() with this exception. + +=back + +=head1 SEE ALSO + +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm new file mode 100644 index 0000000..24ca25d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/Browser.pm @@ -0,0 +1,119 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::Browser; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Util qw{expand_tilde get_url_of_wc is_wc run_command}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my $config = Fcm::Config->instance(); + my $browser + = $self->get_options()->{browser} ? $self->get_options()->{browser} + : $config->setting(qw/WEB_BROWSER/) + ; + my ($target) = $self->get_arguments(); + if (!$target) { + if (is_wc()) { + $target = q{.}; + } + else { + croak(Fcm::CLI::Exception->new({ + message => 'no TARGET specified and . not a working copy', + })); + } + } + $target = expand_tilde($target); + if (-e $target) { + $target = get_url_of_wc($target); + } + + my $browser_url = Fcm::Keyword::get_browser_url($target); + my @command = (split(qr{\s+}xms, $browser), $browser_url); + run_command(\@command, METHOD => 'exec', PRINT => 1); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::Browser + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::Browser; + $invoker = Fcm::CLI::Invoker::Browser->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke a web browser of a VC +location. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes a web browser for a VC target, if it can be mapped to a browser URL. If +a target is not specified in arguments, it uses the current working directory +as the target. + +If the browser option is set, it is used as the browser command. Otherwise, the +default browser is used. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if no target is specified +and a target cannot be deduced from the current working directory. + +=item L + +The invoke() method can croak() with this exception if the target cannot be +mapped to a browser URL. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm new file mode 100644 index 0000000..5639705 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/CM.pm @@ -0,0 +1,69 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::CM; +use base qw{Fcm::CLI::Invoker}; + +use Fcm::Cm qw{cli}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + return cli($self->get_command(), @ARGV); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::CM + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::CM; + $invoker = Fcm::CLI::Invoker::CM->new(); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke a command in the CM +sub-system. + +It is worth noting that this is not yet a full implementation. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes a command in the CM sub-system. + +=back + +=head1 TO DO + +Bring the CM system into this framework. + +Unit tests. + +=head1 SEE ALSO + +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm new file mode 100644 index 0000000..be22fcb --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/CfgPrinter.pm @@ -0,0 +1,105 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::CfgPrinter; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::Exception; +use Fcm::CfgFile; +use Fcm::Config; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my ($cfg_file) = $self->get_arguments(); + if (!$cfg_file) { + croak(Fcm::CLI::Exception->new({message => 'no CFGFILE specified'})); + } + my $cfg = Fcm::CfgFile->new(SRC => $cfg_file); + Fcm::Config->instance()->verbose(0); # suppress message printing to STDOUT + my $read = $cfg->read_cfg(); + if (!$read) { + croak(Fcm::Exception->new({message => sprintf( + "% :cannot read", $cfg_file, + )})); + } + $cfg->print_cfg($self->get_options()->{output}); + } + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::CfgPrinter + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::CfgPrinter; + $invoker = Fcm::CLI::Invoker::CfgPrinter->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke the pretty printer for FCM +configuration files. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the pretty printer for a FCM configuration file. + +If the I option is set, output goes to the location specified by this +value. Otherwise, it prints to STDOUT. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if the configuration file +cannot be read. + +=item L + +The invoke() method can croak() with this exception if no configuration file is +specified. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/ConfigSystem.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/ConfigSystem.pm new file mode 100644 index 0000000..334e39f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/ConfigSystem.pm @@ -0,0 +1,117 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::ConfigSystem; +use base qw{Fcm::CLI::Invoker}; + +use Cwd qw{cwd}; +use Fcm::CLI::Exception; +use Fcm::Config; +use Fcm::Util::ClassLoader; + +################################################################################ +# Returns a hash map to convert CLI options to system invoke options. +sub get_cli2invoke_key_map { + my ($self) = @_; + return ( + wantarray() ? %{$self->{cli2invoke_key_map}} + : $self->{cli2invoke_key_map} + ); +} + +################################################################################ +# Returns the Fcm::ConfigSystem class for invoking the sub-system. +sub get_impl_class { + my ($self) = @_; + return $self->{impl_class}; +} + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my $options_ref = $self->get_options(); + if (exists($options_ref->{verbose})) { + Fcm::Config->instance()->verbose($options_ref->{verbose}); + } + + Fcm::Util::ClassLoader::load($self->get_impl_class()); + my $system = $self->get_impl_class()->new(); + my ($cfg_file) = $self->get_arguments(); + $system->cfg()->src($cfg_file ? $cfg_file : cwd()); + + my %map = $self->get_cli2invoke_key_map(); + my %invoke_args = map {($map{$_}, $options_ref->{$_})} keys(%map); + $system->invoke(%invoke_args); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoke::ConfigSystem + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::ConfigSystem; + $invoker = Fcm::CLI::Invoker::ConfigSystem->new({ + command => $command, + options => \%options, + arguments => $arguments, + impl_class => $class_name, + cli2invoke_key_map => { + option => 'OPTION', + # ... more keys + }, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L and inherits all its +methods. An object of this class is used to invoke a +L, e.g. extract and build. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item get_cli2invoke_key_map() + +Returns a hash containing a mapping table from the names of the relevant command +line options to the names to be given to the invoke() method of the implementing +L object. + +=item get_impl_class() + +Returns the actual class that implements L. +An object of this implementation will be created and used by invoke(). + +=item invoke() + +Invokes the L sub-system. If a +configuration file is not specified in the argument, it uses the current working +directory. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/ExtractConfigComparator.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/ExtractConfigComparator.pm new file mode 100644 index 0000000..eebf529 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/ExtractConfigComparator.pm @@ -0,0 +1,83 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::ExtractConfigComparator; +use base qw{Fcm::CLI::Invoker}; + +use Cwd qw{cwd}; +use Fcm::ExtractConfigComparator; +use Fcm::Config; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my ($cfg_file1, $cfg_file2) = $self->get_arguments(); + if (exists($self->get_options()->{verbose})) { + Fcm::Config->instance()->verbose($self->get_options()->{verbose}); + } + + my $system = Fcm::ExtractConfigComparator->new({ + files => [$cfg_file1, $cfg_file2], wiki => $self->get_options()->{wiki}, + }); + $system->invoke(); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::ExtractInvoker + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::ExtractConfigComparator; + $invoker = Fcm::CLI::Invoker::ExtractConfigComparator->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke the extract configuration +comparator. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the extract configuration comparator. + +The I option is mapped directly to that of the constructor of +L object. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/GUI.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/GUI.pm new file mode 100644 index 0000000..e8ba467 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/GUI.pm @@ -0,0 +1,70 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::GUI; +use base qw{Fcm::CLI::Invoker}; + +use Fcm::Util qw{run_command}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my ($target) = $self->get_arguments(); + run_command(['fcm_gui', ($target ? $target : ())], METHOD => 'exec'); +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::GUIInvoker + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::GUI; + $invoker = Fcm::CLI::Invoker::GUI->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke($command, \%options, $target); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke the FCM GUI. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the FCM GUI. If a target is specified as argument, it is the initial +working directory of the GUI. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/Help.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/Help.pm new file mode 100644 index 0000000..f6f3234 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/Help.pm @@ -0,0 +1,220 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::Help; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::CLI::Config; +use Fcm::Config; +use Fcm::Util qw{run_command}; +use IO::File; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my @subcommand_names = $self->get_arguments(); + if (@subcommand_names) { + for my $subcommand_name (@subcommand_names) { + my $help_string = $self->_get_help_for($subcommand_name); + if (!defined($help_string)) { + croak(Fcm::CLI::Exception->new({message => sprintf( + "%s: unknown command", $subcommand_name, + )})); + } + print($help_string, "\n"); + } + } + else { + print($self->_get_help()); + } +} + +################################################################################ +# Returns the help string for a subcommand matching $subcommand_name +sub _get_help_for { + my ($self, $subcommand_name) = @_; + my $subcommand + = Fcm::CLI::Config->instance()->get_subcommand_of($subcommand_name); + if (!$subcommand) { + return; + } + if ($subcommand->is_vc()) { + my $invoker = $subcommand->get_invoker($subcommand_name); + local(@ARGV) = '--help'; + $invoker->invoke(); + return q{}; + } + my $prog = Fcm::Config->instance()->setting('FCM_COMMAND'); + # FIXME: can do with using Text::Template or Perl6::Form + my $help = sprintf( + "%s %s: %s\n", + $prog, + $subcommand->as_string(), + $subcommand->get_synopsis(), + ); + $help .= sprintf( + "usage: %s %s %s\n", + $prog, $subcommand->get_names()->[0], $subcommand->get_usage(), + ); + if ($subcommand->get_description()) { + my @lines = (q{}, split("\n", $subcommand->get_description()), q{}); + $help .= join(qq{\n }, @lines) . "\n"; + } + if ($subcommand->get_options()) { + $help .= "Valid options:\n"; + my $max_length_of_name = 0; + my @option_names; + for my $option ($subcommand->get_options()) { + if (length($option->get_name()) > $max_length_of_name) { + $max_length_of_name = length($option->get_name()); + } + } + for my $option ($subcommand->get_options()) { + $help .= sprintf( + " --%s%s%s%s : %s\n", + $option->get_name(), + q{ } x ($max_length_of_name - length($option->get_name())), + ( + $option->get_letter() + ? q{ [-} . $option->get_letter() . q{]} : q{ } + ), + ($option->has_arg() ? q{ arg} : q{ } x 4), + $option->get_description(), + ); + } + } + return $help; +} + +################################################################################ +# Returns the general help string +sub _get_help { + my ($self) = @_; + my $release = $self->_get_release(); + + # FIXME: can do with using Text::Template or Perl6::Form + my $prog = Fcm::Config->instance()->setting('FCM_COMMAND'); + my $return = sprintf( + qq{usage: %s [options] [args]\n} + . qq{Flexible configuration management system, release %s.\n} + . qq{Type "%s help " for help on a specific subcommand\n} + . qq{\n} + . qq{Available subcommands:\n} + , + $prog, $release, $prog, + ); + for my $subcommand (Fcm::CLI::Config->instance()->get_core_subcommands()) { + $return .= sprintf(qq{ %s\n}, $subcommand->as_string()); + } + + my @lines = run_command( + [qw/svn help/], DEVNULL => 1, METHOD => 'qx', ERROR => 'ignore', + ); + if (@lines) { + for my $subcommand (Fcm::CLI::Config->instance()->get_vc_subcommands()) { + if (defined($subcommand->get_synopsis())) { + $return .= sprintf(qq{ %s\n}, $subcommand->as_string()); + } + else { + $return .= qq{ \n}; + } + } + $return .= "\n=> svn help\n". join(q{}, @lines); + } + return $return; +} + +################################################################################ +# Returns the release number of the current program +sub _get_release { + my ($self) = @_; + my $release = Fcm::Config->instance()->setting('FCM_RELEASE'); + my $rev_file = Fcm::Config->instance()->setting('FCM_REV_FILE'); + if (-r $rev_file) { + my $handle = IO::File->new($rev_file, 'r'); + if ($handle) { + my $rev = $handle->getline(); + $handle->close(); + chomp($rev); + if ($rev) { + $release .= qq{ (r$rev)}; + } + } + } + return $release; +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::Help + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::Help; + $invoker = Fcm::CLI::Invoker::Help->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to provide help on the command line +interface. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Provides help. If a subcommand name is specified in the argument, provides help +for the specified subcommand. If a subcommand name is not specified, provides +general CLI help. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if the specified subcommand +cannot be identified. + +=back + +=head1 TO DO + +Unit tests. + +Separate logic in this module with that of L. + +Decouples help formatter with this invoker. + +=head1 SEE ALSO + +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/KeywordPrinter.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/KeywordPrinter.pm new file mode 100644 index 0000000..5cfa544 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Invoker/KeywordPrinter.pm @@ -0,0 +1,124 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Invoker::KeywordPrinter; +use base qw{Fcm::CLI::Invoker}; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::Keyword; +use Fcm::Keyword::Formatter::Entries; +use Fcm::Keyword::Formatter::Entry::Location; +use Fcm::Keyword::Exception; +use Fcm::Util qw{get_url_of_wc}; + +################################################################################ +# Invokes the sub-system +sub invoke { + my ($self) = @_; + my @targets = $self->get_arguments(); + if (@targets) { + for my $target (@targets) { + my $entry_list = Fcm::Keyword::get_location_entries_for($target); + my $loc = $target; + if (-e $target) { + $loc = get_url_of_wc($target); + if (!$loc) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: unrecognised version control resource", $target, + )})); + } + } + my @entry_list = Fcm::Keyword::get_location_entries_for($loc); + if (!@entry_list) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: no FCM location keyword found for this target", $target, + )})); + } + my $formatter = Fcm::Keyword::Formatter::Entry::Location->new(); + for my $entry ( + sort {$a->get_key() cmp $b->get_key()} + grep {!$_->is_implied()} + @entry_list + ) { + print($formatter->format($entry), "\n"); + } + } + } + else { + my $formatter = Fcm::Keyword::Formatter::Entries->new(); + print($formatter->format(Fcm::Keyword::get_entries())); + } +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Invoker::KeywordPrinter + +=head1 SYNOPSIS + + use Fcm::CLI::Invoker::KeywordPrinter; + $invoker = Fcm::CLI::Invoker::KeywordPrinter->new({ + command => $command, + options => \%options, + arguments => $arguments, + }); + $invoker->invoke(); + +=head1 DESCRIPTION + +This class extends L an inherits all its +methods. An object of this class is used to invoke the location keyword printer. + +=head1 METHODS + +See L for a list of inherited methods. + +=over 4 + +=item invoke() + +Invokes the location keyword printer. If a namespace is specified in the +argument, prints revision keywords and browser mapping templates for the +specified namespace. If a namespace is not specified, prints all registered +location keywords. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method can croak() with this exception if there is no matching +namespace matching that of the specified. + +=back + +=head1 TO DO + +Unit tests. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Option.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Option.pm new file mode 100644 index 0000000..5a03e44 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Option.pm @@ -0,0 +1,183 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Option; + +use constant NO_ARG => 0; +use constant SCALAR_ARG => 1; +use constant ARRAY_ARG => 2; +use constant HASH_ARG => 3; +use constant ARG_STRING_SUFFIX_FOR => (q{}, q{=s}, q{=s@}, q{=s%}); + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + # Returns the delimiter of this option, if it is an array + 'delimiter', + # Returns the description of this option + 'description', + # Returns the (long) name of this option + 'name', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + return $self->{$key}; + } +} + +################################################################################ +# Returns the letter of this option +sub get_letter { + my ($self) = @_; + if (defined($self->{letter})) { + return substr($self->{letter}, 0, 1); + } + else { + return; + } +} + +################################################################################ +# Returns whether the current option has no, scalar, array or hash arguments +sub has_arg { + my ($self) = @_; + return (defined($self->{has_arg}) ? $self->{has_arg} : $self->NO_ARG); +} + +################################################################################ +# Returns true if this option is associated with help +sub is_help { + my ($self) = @_; + return $self->{is_help}; +} + +################################################################################ +# Returns an option string/reference pair for Getopt::Long::GetOptions +sub get_arg_for_getopt_long { + my ($self) = @_; + my $option_string + = $self->get_name() + . ($self->get_letter() ? q{|} . $self->get_letter() : q{}) + . (ARG_STRING_SUFFIX_FOR)[$self->has_arg()] + ; + return $option_string; +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Option + +=head1 SYNOPSIS + + use Fcm::CLI::Option; + $option = Fcm::CLI::Option->new({ + name => 'name', + letter => 'n', + has_arg => Fcm::CLI::Option->SCALAR_ARG, + is_help => 1, + description => 'an example option', + }); + + # time passes ... + use Getopt::Long qw{GetOptions}; + $success = GetOptions( + \%hash, + $option->get_arg_for_getopt_long(), # ('name|n=s') + # and other options ... + ); + $option_value = $option->get_value(); + +=head1 DESCRIPTION + +An object of this class represents a CLI option. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor. + +=item get_arg_for_getopt_long() + +Returns an option string for this option that is suitable for use as arguments +to L. + +=item get_description() + +Returns a description of this option. + +=item get_delimiter() + +Returns the delimiter of this option. This is only relevant if has_arg() is +equal to C. If set, the argument for this option should be re-grouped +using this delimiter. + +=item get_name() + +Returns the (long) name of this option. + +=item get_letter() + +Returns the option letter of this option. + +=item has_arg() + +Returns whether this option has no, scalar, array or hash arguments. See +L for detail. + +=item is_help() + +Returns true if this option is associated with help. + +=back + +=head1 CONSTANTS + +=over 4 + +=item NO_ARG + +An option has no argument. (Default) + +=item SCALAR_ARG + +An option has a single scalar argument. + +=item ARRAY_ARG + +An option has multiple arguments, which can be placed in an array. + +=item HASH_ARG + +An option has multiple arguments, which can be placed in an hash. + +=back + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Subcommand.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Subcommand.pm new file mode 100644 index 0000000..f549156 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/Subcommand.pm @@ -0,0 +1,245 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::CLI::Subcommand; + +use Carp qw{croak}; +use Fcm::CLI::Exception; +use Fcm::Util::ClassLoader; + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + # Returns the long description of this subcommand + 'description', + # Returns the class of the invoker of this subcommand + 'invoker_class', + # Returns the extra config to be given to the invoker of this subcommand + 'invoker_config', + # Returns the names of this subcommand + 'names', + # Returns the options of this subcommand + 'options', + # Returns the synopsis of this subcommand + 'synopsis', + # Returns the usage of this subcommand + 'usage', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + if (defined($self->{$key})) { + if (ref($self->{$key}) eq 'ARRAY') { + return (wantarray() ? @{$self->{$key}} : $self->{$key}); + } + else { + return $self->{$key}; + } + } + else { + return; + } + } +} + +################################################################################ +# Returns true if this subcommand represents a command in the CM sub-system +sub is_vc { + my ($self) = @_; + return $self->{is_vc}; +} + +################################################################################ +# Returns true if $string matches a name of this subcommand +sub has_a_name { + my ($self, $string) = @_; + if ($self->get_names() && ref($self->get_names()) eq 'ARRAY') { + my %name_of = map {$_, 1} @{$self->get_names()}; + return exists($name_of{$string}); + } + else { + return; + } +} + +################################################################################ +# Invokes this subcommand based on current @ARGV +sub get_invoker { + my ($self, $command) = @_; + my %options = (); + if (($self->get_options())) { + my $problem = q{}; + local($SIG{__WARN__}) = sub { + ($problem) = @_; + }; + my $success = GetOptions( + \%options, + (map {$_->get_arg_for_getopt_long()} ($self->get_options())), + ); + if (!$success) { + croak(Fcm::CLI::Exception->new({message => sprintf( + "%s: option parse failed: %s", $command, $problem, + )})); + } + } + my $invoker_class + = $self->get_invoker_class() ? $self->get_invoker_class() + : 'Fcm::CLI::Invoker' + ; + Fcm::Util::ClassLoader::load($invoker_class); + my $invoker = $invoker_class->new({ + command => $command, + options => \%options, + arguments => [@ARGV], + }); + return $invoker; +} + +################################################################################ +# Returns a simple string representation of this subcommand +sub as_string { + my ($self) = @_; + # FIXME: can do with using Text::Template or Perl6::Form + if ( + $self->get_names() + && ref($self->get_names()) eq 'ARRAY' + && @{$self->get_names()} + ) { + my @names = $self->get_names(); + my $return = $names[0]; + for my $i (1 .. $#names) { + if ($names[$i]) { + $return + .= $i == 1 ? q{ (} . $names[$i] + : q{, } . $names[$i] + ; + } + if ($i == $#names) { + $return .= q{)}; + } + } + return $return; + } + else { + return q{}; + } +} + +1; +__END__ + +=head1 NAME + +Fcm::CLI::Subcommand + +=head1 SYNOPSIS + + use Fcm::CLI::Subcommand; + $subcommand = Fcm::CLI::Subcommand->new({ + names => ['build', 'bld'], + options => [ + Fcm::CLI::Option->new( + # ... some arguments ... + ), + # ... more options + ], + synopsis => 'invokes the build system', + description => $description, + usage => '[OPTIONS] [CONFIG]', + invoker_class => $invoker_class, + invoker_config => { + option1 => $option1, + # ... more options + }, + }); + $boolean = $subcommand->has_a_name($string); + $invoker_class = $subcommand->get_invoker_class(); + +=head1 DESCRIPTION + +An object of this class is used to store the configuration of a subcommand of +the FCM CLI. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor. + +=item get_description() + +Returns the long description of this subcommand. + +=item get_invoker_class() + +Returns the invoker class of this subcommand, which should be a sub-class of +L. + +=item get_invoker_cconfig() + +Returns a reference to a hash containing the extra configuration to be given to +the constructor of the invoker of this subcommand. + +=item get_names() + +Returns an array containing the names of this subcommand. + +=item get_options() + +Returns an array containing the options of this subcommand. Each element of +the array should be a L object. + +=item get_synopsis() + +Returns a short synopsis of this subcommand. + +=item get_usage() + +Returns a short usage statement of this subcommand. + +=item is_vc() + +Returns true if this subcommand represents commands in the underlying VC system. + +=item has_a_name($string) + +Returns true if a name in C<$self-Eget_names()> matches $string. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L + +The invoke() method may croak() with this exception. + +=back + +=head1 SEE ALSO + +L, +L, +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-add.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-add.pod new file mode 100644 index 0000000..acd2a12 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-add.pod @@ -0,0 +1,22 @@ +=head1 NAME + +fcm add + +=head1 SYNOPSIS + + fcm add [options] [args] + +=head1 OPTIONS + +=over 4 + +=item -c [--check] + +Check for any files or directories reported by "L status" as not under +version control and add them. + +=back + +For other options, see output of "L help add". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-branch.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-branch.pod new file mode 100644 index 0000000..d11984b --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-branch.pod @@ -0,0 +1,173 @@ +=head1 NAME + +fcm branch (br) + +=head1 SYNOPSIS + +Create, delete or display information of a branch, or list branches in a +project. + + fcm branch [--info] [OPTIONS] [TARGET] + fcm branch --delete [OPTIONS] [TARGET] + fcm branch --create [OPTIONS] [SOURCE] + fcm branch --list [OPTIONS] [SOURCE] + +=head1 ARGUMENTS + +TARGET (and SOURCE) can be an URL or a Subversion working copy. Otherwise, +the current working directory must be a working copy. For --info and +--delete, the specified URL (or the URL of the working copy) must be a URL +under a valid branch in a standard FCM project. For --create and --list, it +must be a URL under a standard FCM project. + +=head1 OPTIONS + +=over 4 + +=item --info or -i + +Display information about a branch. This is the default option if --create, +--delete and --list are not specified. + +=item --delete or -d + +Delete a branch. + +=item --create or -c + +Create a new branch from SOURCE. The --name option must be used to specify a +short name for the new branch. + +=item --list or -l + +List all the branches owned by the current user in SOURCE. If the --user option +is specified with a list of users, list all the branches owned by these users +instead of the current user. + +=back + +Valid options with --info and --delete: + +=over 4 + +=item -v [--verbose] + +Print extra information. + +=item -a [--show-all] + +Set --show-children, --show-other and --show-siblings. + +=item --show-children + +Report children of the current branch. + +=item --show-other + +Report custom/ reverse merges into the current branch. + +=item --show-siblings + +Report merges with siblings of the current branch. + +=back + +Valid options with --delete and --create: + +=over 4 + +=item --non-interactive + +Do no interactive prompting. This option implies --svn-non-interactive. + +=item --password arg + +Specify a password for write access to the repository. + +=item --svn-non-interactive + +Do no interactive prompting at commit time. This option is implied by +--non-interactive. + +=back + +Valid options with --create and --list: + +=over 4 + +=item -r [--revision] arg + +Specify the operative revision of the SOURCE for creating the branch. + +=back + +Valid options with --create: + +=over 4 + +=item --branch-of-branch + +If this option is specified and the SOURCE is a branch, it will create a new +branch from the SOURCE branch. Otherwise, the branch is created from the trunk. + +=item -k [--ticket] arg + +Specify one (or more) Trac ticket. If specified, the command will add to the +commit log the line "Relates to ticket #". Multiple tickets can be set +by specifying this option multiple times, or by specifying the tickets in a +comma-separated list. + +=item -n [--name] arg + +Specify a short name for the branch, which should contain only characters in the +set [A-Za-z0-9_-.]. + +=item --rev-flag arg + +Specify a flag for determining the prefix of the branch name. The flag can be +the the string "NORMAL", "NUMBER" or "NONE". "NORMAL" is the default behaviour, +in which the branch name will be prefixed with a Subversion revision number if +the revision is not associated with a registered FCM revision keyword. If the +revision is registered with a FCM revision keyword, the keyword will be used in +place of the number. If "NUMBER" is specified, the branch name will always be +prefixed with a Subversion revision number. If "NONE" is specified, the branch +name will not be prefixed by a revision number or keyword. + +=item -t [--type] arg + +Specify the type of the branch to be created. It must be one of the following: + + DEV::USER [DEV, USER] - a development branch for the user + DEV::SHARE [SHARE] - a shared development branch + TEST::USER [TEST] - a test branch for the user + TEST::SHARE - a shared test branch + PKG::USER [PKG] - a package branch for the user + PKG::SHARE - a shared package branch + PKG::CONFIG [CONFIG] - a configuration branch + PKG::REL [REL] - a release branch + +If not specified, the default is to create a development branch for the current +user, i.e. DEV::USER. + +=back + +Valid options with --list: + +=over 4 + +=item -a [--show-all] + +Print all branches. + +=item -u [--user] arg + +Specify a colon-separated list of users. List branches owned by these users +instead of the current user. + +=item -v [--verbose] + +Print Subversion URL instead of FCM URL keywords. + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-commit.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-commit.pod new file mode 100644 index 0000000..6d19012 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-commit.pod @@ -0,0 +1,31 @@ +=head1 NAME + +fcm commit (ci) + +=head1 SYNOPSIS + + fcm commit [OPTIONS] [PATH ...] + +Send changes from your working copy to the repository. Invoke your favourite +editor to prompt you for a commit log message. Update your working copy +following the commit. + +=head1 OPTIONS + +=over 4 + +=item --dry-run + +Allows you to add to the commit message without committing. + +=item --svn-non-interactive + +Do no interactive prompting at commit time. + +=item --password arg + +Specify a password ARG. + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-conflicts.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-conflicts.pod new file mode 100644 index 0000000..d4a3453 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-conflicts.pod @@ -0,0 +1,17 @@ +=head1 NAME + +fcm conflicts (cf) + +=head1 SYNOPSIS + +Use graphical tool to resolve any conflicts within your working copy. + + fcm conflicts [PATH] + +=head1 ARGUMENTS + +Invoke a graphical merge tool to help you resolve conflicts in your working copy +at PATH. It prompts you to run "L resolved" each time you have resolved +the conflicts in a text file. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-delete.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-delete.pod new file mode 100644 index 0000000..7852356 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-delete.pod @@ -0,0 +1,22 @@ +=head1 NAME + +fcm delete (del, remove, rm) + +=head1 SYNOPSIS + + fcm delete [options] [args] + +=head1 OPTIONS + +=over 4 + +=item -c [--check] + +Check for any files or directories reported by "L status" as missing +and schedule them for removal. + +=back + +For other options, see output of "L help delete". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-diff.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-diff.pod new file mode 100644 index 0000000..29168d9 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-diff.pod @@ -0,0 +1,79 @@ +=head1 NAME + +fcm diff (di) + +=head1 SYNOPSIS + + 1. fcm diff --branch [OPTIONS] [TARGET] + 2. fcm diff [OPTIONS] [ARGS] + +=over 4 + +=item 1. + +Show differences relative to the base of the target branch, i.e. the changes +available for merging from the target branch into its parent. If TARGET is +specified, it must either be a URL or a working copy. Otherwise, the target is +the the current directory which must be a working copy. The target URL must be a +branch in a standard FCM project. + +=item 2. + +See description of "L diff" below. + +=back + +=head1 OPTIONS + +Valid options with --branch: + +=over 4 + +=item --diff-cmd arg + +As described below in the help for "L diff". + +=item -g [--graphical] + +As described below. + +=item --summarise + +As described below + +=item --summarize + +As described below in the help for "L diff". + +=item -t [--trac] + +If TARGET is a URL, use Trac to display the diff. + +=item --wiki + +If TARGET is a URL, print Trac link for the diff. + +=item -x [--extensions] arg + +As described below in the help for "L diff". + +=back + +Other options: + +=over 4 + +=item -g [--graphical] + +Use a graphical diff tool to display the differences. This option should not be +used in combination with --diff-cmd. + +=item --summarise + +Same as --summarize as described below. + +=back + +For other options, see output of "L help diff". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-merge.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-merge.pod new file mode 100644 index 0000000..00a2d18 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-merge.pod @@ -0,0 +1,71 @@ +=head1 NAME + +fcm merge + +=head1 SYNOPSIS + +Merge changes from a source into your working copy. + + 1. fcm merge SOURCE + 2. fcm merge --custom --revision N[:M] SOURCE + fcm merge --custom URL[\@REV1] URL[\@REV2] + 3. fcm merge --reverse --revision [M:]N + +=over 4 + +=item 1. + +If neither --custom nor --reverse is specified, the command merges changes +automatically from SOURCE into your working copy. SOURCE must be a valid +URL[@REV] of a branch in a standard FCM project. The base of the merge will be +calculated automatically based on the common ancestor and latest merge +information between the SOURCE and the branch of the working copy. + +=item 2. + +If --custom is specified, the command can be used in two forms. + +In the first form, it performs a custom merge from the specified changeset(s) of +SOURCE into your working copy. SOURCE must be a valid URL[@REV] of a branch in +a standard FCM project. If a single revision is specified, the merge delta is (N +- 1):N of SOURCE. Otherwise, the merge delta, is N:M of SOURCE, where N < M. + +In the second form, it performs a custom merge using the delta between the two +specified branch URLs. For each URL, if a peg revision is not specified, the +command will peg the URL with its last changed revision. + +=item 3. + +If --reverse is specified, the command performs a reverse merge of the +changeset(s) specified by the --revision option. If a single revision is +specified, the merge delta is N:(N - 1). Otherwise, the merge delta is M:N, +where M > N. Note that you do not have to specify a SOURCE for a reverse merge, +because the SOURCE should always be the branch your working copy is pointing to. + +=back + +The command provide a commit log message template following the merge. + +=head1 OPTIONS + +=over 4 + +=item --dry-run + +Try operation but make no changes. + +=item --non-interactive + +Do no interactive prompting. + +=item -r [--revision] arg + +Specify a (range of) revision number(s). + +=item --verbose + +Print extra information. + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-mkpatch.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-mkpatch.pod new file mode 100644 index 0000000..22c8b14 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-mkpatch.pod @@ -0,0 +1,60 @@ +=head1 NAME + +fcm mkpatch + +=head1 SYNOPSIS + +mkpatch: Create patches from specified revisions of a URL + + fcm mkpatch [OPTIONS] URL [OUTDIR] + +Create patches from specified revisions of the specified URL. If OUTDIR is +specified, the output is sent to OUTDIR. Otherwise, the output will be sent to a +default location in the current directory ($PWD/fcm-mkpatch-out). The output +directory will contain the patch for each revision as well as a script for +importing the patch. + +A warning is given if the URL is not of a branch in a FCM project or if it is a +sub-directory of a branch. + +=head1 OPTIONS + +=over 4 + +=item --exclude arg + +Exclude a path in the URL. Multiple paths can be specified by using a +colon-separated list of paths, or by specifying this option multiple times. + +The specified path must be a relative path of the URL. Glob patterns such as * +and ? are acceptable. Changes in an excluded path will not be considered in the +patch. A changeset containing changes only in the excluded path will not be +considered at all. + +=item --organisation arg + +This option can be used to specify the name of your organisation. + +The command will attempt to parse the commit log message for each revision in +the patch. It will remove all merge templates, replace Trac links with a +modified string, and add information about the original changeset. If you +specify the name of your organisation, it will replace Trac links such as +"ticket:123" with "$organisation_ticket:123", and report the original changeset +with a message such as "$organisation_changeset:1000". If the organisation +name is not specified then it defaults to "original". + +=item -r [--revision] arg + +Specify a revision number or a revision number range. + +If a revision is specified with the --revision option, it will attempt to create +a patch based on the changes at that revision. If a revision is not specified, +it will attempt to create a patch based on the changes at the HEAD revision. If +a revision range is specified, it will attempt to create a patch for each +revision in that range (including the change in the lower range) where changes +have taken place in the URL. No output will be written if there is no change in +the given revision (range). + +=back + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-switch.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-switch.pod new file mode 100644 index 0000000..18f7417 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-switch.pod @@ -0,0 +1,14 @@ +=head1 NAME + +fcm switch (sw) + +=head1 SYNOPSIS + + 1. switch URL [PATH] + 2. switch --relocate FROM TO [PATH...] + +Note: if --relocate is not specified, "fcm switch" will only support the options +--non-interactive, -r [--revision] and -q [--quiet]. For detail, see the output +of "L help switch". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-update.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-update.pod new file mode 100644 index 0000000..7a20ad4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CLI/fcm-update.pod @@ -0,0 +1,14 @@ +=head1 NAME + +fcm update (up) + +=head1 SYNOPSIS + +Bring changes from the repository into the working copy. + + usage: update [PATH...] + +Note: "fcm update" only supports --non-interactive, -r [--revision] arg and -q +[--quiet]. For detail, see the output of "L help update". + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CfgFile.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CfgFile.pm new file mode 100644 index 0000000..1eeee89 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CfgFile.pm @@ -0,0 +1,681 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CfgFile +# +# DESCRIPTION +# This class is used for reading and writing FCM config files. A FCM config +# file is a line-based text file that provides information on how to perform +# a particular task using the FCM system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CfgFile; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use Carp; +use File::Basename; +use File::Path; +use File::Spec; + +# FCM component modules +use Fcm::Base; +use Fcm::CfgLine; +use Fcm::Config; +use Fcm::Keyword; +use Fcm::Util; + +# List of property methods for this class +my @scalar_properties = ( + 'actual_src', # actual source of configuration file + 'lines', # list of lines, Fcm::CfgLine objects + 'pegrev', # peg revision of configuration file + 'src', # source of configuration file + 'type', # type of configuration file + 'version', # version of configuration file +); + +# Local module variables +my $expand_type = 'bld|ext'; # config file type that needs variable expansions + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::CfgFile->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CfgFile class. See above +# for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + bless $self, $class; + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + if (@_) { + $self->{$name} = $_[0]; + } + + if (not defined $self->{$name}) { + if ($name eq 'lines') { + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $mtime = $obj->mtime (); +# +# DESCRIPTION +# This method returns the modified time of the configuration file source. +# ------------------------------------------------------------------------------ + +sub mtime { + my $self = shift; + my $mtime = undef; + + if (-f $self->src) { + $mtime = (stat $self->src)[9]; + } + + return $mtime; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $read = $obj->read_cfg (); +# +# DESCRIPTION +# This method reads the current configuration file. It returns the number of +# lines read from the config file, or "undef" if it fails. The result is +# placed in the LINES array of the current instance, and can be accessed via +# the "lines" method. +# ------------------------------------------------------------------------------ + +sub read_cfg { + my $self = shift; + + my @lines = $self->_get_cfg_lines; + + # List of CFG types that need INC declarations expansion + my %exp_inc = (); + for (split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_EXP_INC'))) { + $exp_inc{uc ($_)} = 1; + } + + # List of CFG labels that are reserved keywords + my %cfg_keywords = (); + for (split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD'))) { + $cfg_keywords{$self->cfglabel ($_)} = 1; + } + + # Loop each line, to separate lines into label : value pairs + my $cont = undef; + my $here = undef; + for my $line_num (1 .. @lines) { + my $line = $lines[$line_num - 1]; + chomp $line; + + my $label = ''; + my $value = ''; + my $comment = ''; + + # If this line is a continuation, set $start to point to the line that + # starts this continuation. Otherwise, set $start to undef + my $start = defined ($cont) ? $self->lines->[$cont] : undef; + my $warning = undef; + + if ($line =~ /^(\s*#.*)$/) { # comment line + $comment = $1; + + } elsif ($line =~ /\S/) { # non-blank line + if (defined $cont) { + # Previous line has a continuation mark + $value = $line; + + # Separate value and comment + if ($value =~ s/((?:\s+|^)#\s+.*)$//) { + $comment = $1; + } + + # Remove leading spaces + $value =~ s/^\s*\\?//; + + # Expand environment variables + my $warn; + ($value, $warn) = $self->_expand_variable ($value, 1) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + + # Expand internal variables + ($value, $warn) = $self->_expand_variable ($value, 0) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + + # Get "line" that begins the current continuation + my $v = $start->value . $value; + $v =~ s/\\$//; + $start->value ($v); + + } else { + # Previous line does not have a continuation mark + if ($line =~ /^\s*(\S+)(?:\s+(.*))?$/) { + # Check line contains a valid label:value pair + $label = $1; + $value = defined ($2) ? $2 : ''; + + # Separate value and comment + if ($value =~ s/((?:\s+|^)#\s+.*)$//) { + $comment = $1; + } + + # Remove trailing spaces + $value =~ s/\s+$//; + + # Value begins with $HERE? + $here = ($value =~ /\$\{?HERE\}?(?:[^A-Z_]|$)/); + + # Expand environment variables + my $warn; + ($value, $warn) = $self->_expand_variable ($value, 1) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + + # Expand internal variables + ($value, $warn) = $self->_expand_variable ($value, 0) if $value; + $warning .= ($warning ? ', ' : '') . $warn if $warn; + } + } + + # Determine whether current line ends with a continuation mark + if ($value =~ s/\\$//) { + $cont = scalar (@{ $self->lines }) unless defined $cont; + + } else { + $cont = undef; + } + } + + if ( defined($self->type()) + && exists($exp_inc{uc($self->type())}) + && uc($start ? $start->label() : $label) eq $self->cfglabel('INC') + && !defined($cont) + ) { + # Current configuration file requires expansion of INC declarations + # The start/current line is an INC declaration + # The current line is not a continuation or is the end of the continuation + + # Get lines from an "include" configuration file + my $src = ($start ? $start->value : $value); + $src .= '@' . $self->pegrev if $here and $self->pegrev; + + if ($src) { + # Invoke a new instance to read the source + my $cfg = Fcm::CfgFile->new ( + SRC => expand_tilde ($src), TYPE => $self->type, + ); + + $cfg->read_cfg; + + # Add lines to the lines array in the current configuration file + $comment = 'INC ' . $src . ' '; + push @{$self->lines}, Fcm::CfgLine->new ( + comment => $comment . '# Start', + number => ($start ? $start->number : $line_num), + src => $self->actual_src, + warning => $warning, + ); + push @{ $self->lines }, @{ $cfg->lines }; + push @{$self->lines}, Fcm::CfgLine->new ( + comment => $comment . '# End', + src => $self->actual_src, + ); + + } else { + push @{$self->lines}, Fcm::CfgLine->new ( + number => $line_num, + src => $self->actual_src, + warning => 'empty INC declaration.' + ); + } + + } else { + # Push label:value pair into lines array + push @{$self->lines}, Fcm::CfgLine->new ( + label => $label, + value => ($label ? $value : ''), + comment => $comment, + number => $line_num, + src => $self->actual_src, + warning => $warning, + ); + } + + next if defined $cont; # current line not a continuation + + my $slabel = ($start ? $start->label : $label); + my $svalue = ($start ? $start->value : $value); + next unless $slabel; + + # Check config file type and version + if (index (uc ($slabel), $self->cfglabel ('CFGFILE')) == 0) { + my @words = split /$Fcm::Config::DELIMITER_PATTERN/, $slabel; + shift @words; + + my $name = @words ? lc ($words[0]) : 'type'; + + if ($self->can ($name)) { + $self->$name ($svalue); + } + } + + # Set internal variable + $slabel =~ s/^\%//; # Remove leading "%" from label + + $self->config->variable ($slabel, $svalue) + unless exists $cfg_keywords{$slabel}; + } + + # Report and reset warnings + # ---------------------------------------------------------------------------- + for my $line (@{ $self->lines }) { + w_report $line->format_warning if $line->warning; + $line->warning (undef); + } + + return @{ $self->lines }; + +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->print_cfg ($file, [$force]); +# +# DESCRIPTION +# This method prints the content of current configuration file. If no +# argument is specified, it prints output to the standard output. If $file is +# specified, and is a writable file name, the output is sent to the file. If +# the file already exists, its content is compared to the current output. +# Nothing will be written if the content is unchanged unless $force is +# specified. Otherwise, for typed configuration files, the existing file is +# renamed using a prefix that contains its last modified time. The method +# returns 1 if there is no error. +# ------------------------------------------------------------------------------ + +sub print_cfg { + my ($self, $file, $force) = @_; + + # Count maximum number of characters in the labels, (for pretty printing) + my $max_label_len = 0; + for my $line (@{ $self->lines }) { + next unless $line->label; + my $label_len = length $line->label; + $max_label_len = $label_len if $label_len > $max_label_len; + } + + # Output string + my $out = ''; + + # Append each line of the config file to the output string + for my $line (@{ $self->lines }) { + $out .= $line->print_line ($max_label_len - length ($line->label) + 1); + $out .= "\n"; + } + + if ($out) { + my $old_select = select; + + # Open file if necessary + if ($file) { + # Make sure the host directory exists and is writable + my $dirname = dirname $file; + if (not -d $dirname) { + print 'Make directory: ', $dirname, "\n" if $self->verbose; + mkpath $dirname; + } + croak $dirname, ': cannot write to config file directory, abort' + unless -d $dirname and -w $dirname; + + if (-f $file and not $force) { + if (-r $file) { + # Read old config file to see if content has changed + open IN, '<', $file or croak $file, ': cannot open (', $!, '), abort'; + my $in_lines = ''; + while (my $line = ) { + $in_lines .= $line; + } + close IN or croak $file, ': cannot close (', $!, '), abort'; + + # Return if content is up-to-date + if ($in_lines eq $out) { + print 'No change in ', lc ($self->type), ' cfg: ', $file, "\n" + if $self->verbose > 1 and $self->type; + return 1; + } + } + + # If config file already exists, make sure it is writable + if (-w $file) { + if ($self->type) { + # Existing config file writable, rename it using its time stamp + my $mtime = (stat $file)[9]; + my ($sec, $min, $hour, $mday, $mon, $year) = (gmtime $mtime)[0 .. 5]; + my $timestamp = sprintf '%4d%2.2d%2.2d_%2.2d%2.2d%2.2d_', + $year + 1900, $mon + 1, $mday, $hour, $min, $sec; + my $oldfile = File::Spec->catfile ( + $dirname, $timestamp . basename ($file) + ); + rename $file, $oldfile; + print 'Rename existing ', lc ($self->type), ' cfg: ', + $oldfile, "\n" if $self->verbose > 1; + } + + } else { + # Existing config file not writable, throw an error + croak $file, ': config file not writable, abort'; + } + } + + # Open file and select file handle + open OUT, '>', $file + or croak $file, ': cannot open config file (', $!, '), abort'; + select OUT; + } + + # Print output + print $out; + + # Close file if necessary + if ($file) { + select $old_select; + close OUT or croak $file, ': cannot close config file (', $!, '), abort'; + + if ($self->type and $self->verbose > 1) { + print 'Generated ', lc ($self->type), ' cfg: ', $file, "\n"; + + } elsif ($self->verbose > 2) { + print 'Generated cfg: ', $file, "\n"; + } + } + + } else { + # Warn if nothing to print + my $warning = 'Empty configuration'; + $warning .= ' - nothing written to file: ' . $file if $file; + carp $warning if $self->type; + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @lines = $self->_get_cfg_lines (); +# +# DESCRIPTION +# This internal method reads from a configuration file residing in a +# Subversion repository or in the normal file system. +# ------------------------------------------------------------------------------ + +sub _get_cfg_lines { + my $self = shift; + my @lines = (); + + my $verbose = $self->verbose; + + my ($src) = $self->src(); + if ($src =~ qr{\A([A-Za-z][\w\+-\.]*):}xms) { # is a URI + $src = Fcm::Keyword::expand($src); + # Config file resides in a SVN repository + # -------------------------------------------------------------------------- + # Set URL source and version + my $rev = 'HEAD'; + + # Extract version from source if it exists + if ($src =~ s{\@ ([^\@]+) \z}{}xms) { + $rev = $1; + } + + $src = Fcm::Util::tidy_url($src); + + # Check whether URL is a config file + my $rc; + my @cmd = (qw/svn cat/, $src . '@' . $rev); + @lines = &run_command ( + \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', + ); + + # Error in "svn cat" command + if ($rc) { + # See whether specified config file is a known type + my %cfgname = %{ $self->setting ('CFG_NAME') }; + my $key = uc $self->type; + my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; + + # If config file is a known type, specified URL may be a directory + if ($file) { + # Check whether a config file with a default name exists in the URL + my $path = $src . '/' . $file; + my @cmd = (qw/svn cat/, $path . '@' . $rev); + + @lines = &run_command ( + \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', + ); + + # Check whether a config file with a default name exists under the "cfg" + # sub-directory of the URL + if ($rc) { + my $cfgdir = $self->setting (qw/DIR CFG/); + $path = $src . '/' . $cfgdir . '/' . $file; + my @cmd = (qw/svn cat/, $path . '@' . $rev); + + @lines = &run_command ( + \@cmd, METHOD => 'qx', DEVNULL => 1, RC => \$rc, ERROR => 'ignore', + ); + } + + $src = $path unless $rc; + } + } + + if ($rc) { + # Error in "svn cat" + croak 'Unable to locate config file from "', $self->src, '", abort'; + + } else { + # Print diagnostic, if necessary + if ($verbose and $self->type and $self->type =~ /$expand_type/) { + print 'Config file (', $self->type, '): ', $src; + print '@', $rev if $rev; + print "\n"; + } + } + + # Record the actual source location + $self->pegrev ($rev); + $self->actual_src ($src); + + } else { + # Config file resides in the normal file system + # -------------------------------------------------------------------------- + my $src = $self->src; + + if (-d $src) { # Source is a directory + croak 'Config file "', $src, '" is a directory, abort' if not $self->type; + + # Get name of the config file by looking at the type + my %cfgname = %{ $self->setting ('CFG_NAME') }; + my $key = uc $self->type; + my $file = exists $cfgname{$key} ? $cfgname{$key} : ''; + + if ($file) { + my $cfgdir = $self->setting (qw/DIR CFG/); + + # Check whether a config file with a default name exists in the + # specified path, then check whether a config file with a default name + # exists under the "cfg" sub-directory of the specified path + if (-f File::Spec->catfile ($self->src, $file)) { + $src = File::Spec->catfile ($self->src, $file); + + } elsif (-f File::Spec->catfile ($self->src, $cfgdir, $file)) { + $src = File::Spec->catfile ($self->src, $cfgdir, $file); + + } else { + croak 'Unable to locate config file from "', $self->src, '", abort'; + } + + } else { + croak 'Unknown config file type "', $self->type, '", abort'; + } + } + + if (-r $src) { + open FILE, '<', $src; + print 'Config file (', $self->type, '): ', $src, "\n" + if $verbose and $self->type and $self->type =~ /$expand_type/; + + @lines = readline 'FILE'; + close FILE; + + } else { + croak 'Unable to read config file "', $src, '", abort'; + } + + # Record the actual source location + $self->actual_src ($src); + } + + return @lines; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_expand_variable ($string, $env[, \%recursive]); +# +# DESCRIPTION +# This internal method expands variables in $string. If $env is true, it +# expands environment variables. Otherwise, it expands local variables. If +# %recursive is set, it indicates that this method is being called +# recursively. In which case, it must not attempt to expand a variable that +# exists in the keys of %recursive. +# ------------------------------------------------------------------------------ + +sub _expand_variable { + my ($self, $string, $env, $recursive) = @_; + + # Pattern for environment/local variable + my @patterns = $env + ? (qr#\$([A-Z][A-Z0-9_]+)#, qr#\$\{([A-Z][A-Z0-9_]+)\}#) + : (qr#%(\w+(?:::[\w\.-]+)*)#, qr#%\{(\w+(?:(?:::|/)[\w\.-]+)*)\}#); + + my $ret = ''; + my $warning = undef; + while ($string) { + # Find the first match in $string + my ($prematch, $match, $postmatch, $var_label); + for my $pattern (@patterns) { + next unless $string =~ /$pattern/; + if ((not defined $prematch) or length ($`) < length ($prematch)) { + $prematch = $`; + $match = $&; + $var_label = $1; + $postmatch = $'; + } + } + + if ($match) { + $ret .= $prematch; + $string = $postmatch; + + # Get variable value from environment or local configuration + my $variable = $env + ? (exists $ENV{$var_label} ? $ENV{$var_label} : undef) + : $self->config->variable ($var_label); + + if ($env and $var_label eq 'HERE' and not defined $variable) { + $variable = dirname ($self->actual_src); + $variable = File::Spec->rel2abs ($variable) if not &is_url ($variable); + } + + # Substitute match with value of variable + if (defined $variable) { + my $cyclic = 0; + if ($recursive) { + if (exists $recursive->{$var_label}) { + $cyclic = 1; + + } else { + $recursive->{$var_label} = 1; + } + + } else { + $recursive = {$var_label => 1}; + } + + if ($cyclic) { + $warning .= ', ' if $warning; + $warning .= $match . ': cyclic dependency, variable not expanded'; + $ret .= $variable; + + } else { + my ($r, $w) = $self->_expand_variable ($variable, $env, $recursive); + $ret .= $r; + if ($w) { + $warning .= ', ' if $warning; + $warning .= $w; + } + } + + } else { + $warning .= ', ' if $warning; + $warning .= $match . ': variable not expanded'; + $ret .= $match; + } + + } else { + $ret .= $string; + $string = ""; + } + } + + return ($ret, $warning); +} + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CfgLine.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CfgLine.pm new file mode 100644 index 0000000..4a2f710 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CfgLine.pm @@ -0,0 +1,333 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CfgLine +# +# DESCRIPTION +# This class is used for grouping the settings in each line of a FCM +# configuration file. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CfgLine; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use File::Basename; + +# In-house modules +use Fcm::Base; +use Fcm::Config; +use Fcm::Util; + +# List of property methods for this class +my @scalar_properties = ( + 'bvalue', # line value, in boolean + 'comment', # (in)line comment + 'error', # error message for incorrect usage while parsing the line + 'label', # line label + 'line', # content of the line + 'number', # line number in source file + 'parsed', # has this line been parsed (by the extract/build system)? + 'prefix', # optional prefix for line label + 'slabel', # label without the optional prefix + 'src', # name of source file + 'value', # line value + 'warning', # warning message for deprecated usage +); + +# Useful variables +our $COMMENT_RULER = '-' x 78; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = Fcm::CfgLine->comment_block (@comment); +# +# DESCRIPTION +# This method returns a list of Fcm::CfgLine objects representing a comment +# block with the comment string @comment. +# ------------------------------------------------------------------------------ + +sub comment_block { + my @return = ( + Fcm::CfgLine->new (comment => $COMMENT_RULER), + (map {Fcm::CfgLine->new (comment => $_)} @_), + Fcm::CfgLine->new (comment => $COMMENT_RULER), + Fcm::CfgLine->new (), + ); + + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::CfgLine->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CfgLine class. See above +# for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + $self->{$_} = $args{$_} if exists $args{$_}; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + if (@_) { + $self->{$name} = $_[0]; + + if ($name eq 'line' or $name eq 'label') { + $self->{slabel} = undef; + + } elsif ($name eq 'line' or $name eq 'value') { + $self->{bvalue} = undef; + } + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name =~ /^(?:comment|error|label|line|prefix|src|value)$/) { + # Blank + $self->{$name} = ''; + + } elsif ($name eq 'slabel') { + if ($self->prefix and $self->label_starts_with ($self->prefix)) { + $self->{$name} = $self->label_from_field (1); + + } else { + $self->{$name} = $self->label; + } + + } elsif ($name eq 'bvalue') { + if (defined ($self->value)) { + $self->{$name} = ($self->value =~ /^(\s*|false|no|off|0*)$/i) + ? 0 : $self->value; + } + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @fields = $obj->label_fields (); +# @fields = $obj->slabel_fields (); +# +# DESCRIPTION +# These method returns a list of fields in the (s)label. +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_fields'; + *$sub_name = sub { + return (split (/$Fcm::Config::DELIMITER_PATTERN/, $_[0]->$name)); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->label_from_field ($index); +# $string = $obj->slabel_from_field ($index); +# +# DESCRIPTION +# These method returns the (s)label from field $index onwards. +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_from_field'; + *$sub_name = sub { + my ($self, $index) = @_; + my $method = $name . '_fields'; + my @fields = $self->$method; + return join ($Fcm::Config::DELIMITER, @fields[$index .. $#fields]); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->label_starts_with (@fields); +# $flag = $obj->slabel_starts_with (@fields); +# +# DESCRIPTION +# These method returns a true if (s)label starts with the labels in @fields +# (ignore case). +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_starts_with'; + *$sub_name = sub { + my ($self, @fields) = @_; + my $return = 1; + + my $method = $name . '_fields'; + my @all_fields = $self->$method; + + for my $i (0 .. $#fields) { + next if lc ($fields[$i]) eq lc ($all_fields[$i] || ''); + $return = 0; + last; + } + + return $return; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->label_starts_with_cfg (@fields); +# $flag = $obj->slabel_starts_with_cfg (@fields); +# +# DESCRIPTION +# These method returns a true if (s)label starts with the configuration file +# labels in @fields (ignore case). +# ------------------------------------------------------------------------------ + +for my $name (qw/label slabel/) { + no strict 'refs'; + + my $sub_name = $name . '_starts_with_cfg'; + *$sub_name = sub { + my ($self, @fields) = @_; + + for my $field (@fields) { + $field = $self->cfglabel ($field); + } + + my $method = $name . '_starts_with'; + return $self->$method (@fields); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $mesg = $obj->format_error (); +# +# DESCRIPTION +# This method returns a string containing a formatted error message for +# anything reported to the current line. +# ------------------------------------------------------------------------------ + +sub format_error { + my ($self) = @_; + my $mesg = ''; + + $mesg .= $self->format_warning; + + if ($self->error or not $self->parsed) { + $mesg = 'ERROR: ' . $self->src . ': LINE ' . $self->number . ':' . "\n"; + if ($self->error) { + $mesg .= ' ' . $self->error; + + } else { + $mesg .= ' ' . $self->label . ': label not recognised.'; + } + } + + return $mesg; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $mesg = $obj->format_warning (); +# +# DESCRIPTION +# This method returns a string containing a formatted warning message for +# any warning reported to the current line. +# ------------------------------------------------------------------------------ + +sub format_warning { + my ($self) = @_; + my $mesg = ''; + + if ($self->warning) { + $mesg = 'WARNING: ' . $self->src . ': LINE ' . $self->number . ':' . "\n"; + $mesg .= ' ' . $self->warning; + } + + return $mesg; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $line = $obj->print_line ([$space]); +# +# DESCRIPTION +# This method returns a configuration line using $self->label, $self->value +# and $self->comment. The value in $self->line is re-set. If $space is set +# and is a positive integer, it sets the spacing between the label and the +# value in the line. The default is 1. +# ------------------------------------------------------------------------------ + +sub print_line { + my ($self, $space) = @_; + + # Set space between label and value, default to 1 character + $space = 1 unless $space and $space =~ /^[1-9]\d*$/; + + my $line = ''; + + # Add label and value, if label is set + if ($self->label) { + $line .= $self->label . ' ' x $space; + $line .= $self->value if defined $self->value; + } + + # Add comment if necessary + my $comment = $self->comment; + $comment =~ s/^\s*//; + + if ($comment) { + $comment = '# ' . $comment if $comment !~ /^#/; + $line .= ' ' if $line; + $line .= $comment; + } + + return $self->line ($line); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Cm.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Cm.pm new file mode 100644 index 0000000..55bd30c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Cm.pm @@ -0,0 +1,2721 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Cm +# +# DESCRIPTION +# This module contains the FCM code management functionalities and wrappers +# to Subversion commands. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Cm; +use base qw{Exporter}; + +our @EXPORT_OK = qw(cli cm_check_missing cm_check_unknown cm_switch cm_update); + +use Cwd qw{cwd}; +use Getopt::Long qw{GetOptions :config bundling}; +use Fcm::CLI::Exception; +use Fcm::Config; +use Fcm::CmBranch; +use Fcm::CmUrl; +use Fcm::Keyword; +use Fcm::Util qw{ + get_url_of_wc + get_url_peg_of_wc + get_wct + is_url + is_wc + run_command + tidy_url +}; +use File::Basename qw{basename dirname}; +use File::Path qw{mkpath rmtree}; +use File::Spec; +use File::Temp qw{tempfile}; +use Pod::Usage qw{pod2usage}; + +# ------------------------------------------------------------------------------ + +# CLI message handler +our $CLI_MESSAGE = \&_cli_message; + +# List of CLI messages +our %CLI_MESSAGE_FOR = ( + q{} => "%s", + BRANCH_LIST => "%s at %s: %d branch(es) found for %s.\n", + CHDIR_WCT => "%s: working directory changed to top of working copy.\n", + CF => "Conflicts in: %s\n", + MERGE => "Performing merge ...\n", + MERGE_CF => "About to merge in changes from %s compared with %s\n", + MERGE_CI => "The following is added to the commit message file:\n%s", + MERGE_DRY => "This merge will result in the following change:\n", + MERGE_REVS => "Merge(s) available from %s: %s\n", + OUT_DIR => "Output directory: %s\n", + PATCH_DONE => "%s: patch generated.\n", + PATCH_REV => "Patch created for changeset %s\n", + SEPARATOR => q{-} x 80 . "\n", + STATUS => "Status of the target working copy(ies):\n%s", +); + +# CLI abort and error messages +our %CLI_MESSAGE_FOR_ABORT = ( + FAIL => "%s: command failed.\n", + NULL => "%s: command will result in no change.\n", + USER => "%s: abort by user.\n", +); + +# CLI abort and error messages +our %CLI_MESSAGE_FOR_ERROR = ( + CHDIR => "%s: cannot change to directory.\n", + CLI => "%s", + CLI_HELP => "Type 'fcm help %s' for usage.\n", + CLI_MERGE_ARG1 => "Arg 1 must be the source in auto/custom mode.\n", + CLI_MERGE_ARG2 => "Arg 2 must be the source in custom mode" + . " if --revision not set.\n", + CLI_OPT_ARG => "--%s: invalid argument [%s].\n", + CLI_OPT_WITH_OPT => "--%s: must be specified with --%s.\n", + CLI_USAGE => "incorrect usage", + DIFF_PROJECTS => "%s (target) and %s (source) are not related.\n", + INVALID_BRANCH => "%s: not a valid URL of a standard FCM branch.\n", + INVALID_PROJECT => "%s: not a valid URL of a standard FCM project.\n", + INVALID_TARGET => "%s: not a valid working copy or URL.\n", + INVALID_URL => "%s: not a valid URL.\n", + INVALID_WC => "%s: not a valid working copy.\n", + MERGE_REV_INVALID => "%s: not a revision in the available merge list.\n", + MERGE_SELF => "%s: cannot be merged to its own working copy: %s.\n", + MERGE_UNRELATED => "%s: target and %s: source not directly related.\n", + MERGE_UNSAFE => "%s: source contains changes outside the target" + . " sub-directory. Please merge with a full tree.\n", + MKPATH => "%s: cannot create directory.\n", + NOT_EXIST => "%s: does not exist.\n", + PARENT_NOT_EXIST => "%s: parent %s no longer exists.\n", + RMTREE => "%s: cannot remove.\n", + ST_CONFLICT => "File(s) in conflicts:\n%s", + ST_MISSING => "File(s) missing:\n%s", + ST_OUT_OF_DATE => "File(s) out of date:\n%s", + SWITCH_UNSAFE => "%s: merge template exists." + . " Please remove before retrying.\n", + WC_EXIST => "%s: working copy already exists.\n", + WC_INVALID_BRANCH => "%s: not a working copy of a standard FCM branch.\n", + WC_URL_NOT_EXIST => "%s: working copy URL does not exists at HEAD.\n", +); + +# List of CLI prompt messages +our %CLI_MESSAGE_FOR_PROMPT = ( + CF_OVERWRITE => qq{%s: existing changes will be overwritten.\n} + . qq{ Do you wish to continue?}, + CI => qq{Would you like to commit this change?}, + CI_BRANCH_SHARED => qq{\n} + . qq{*** WARNING: YOU ARE COMMITTING TO A %s BRANCH.\n} + . qq{*** Please ensure that you have the} + . qq{ owner's permission.\n\n} + . qq{Would you like to commit this change?}, + CI_BRANCH_USER => qq{\n} + . qq{*** WARNING: YOU ARE COMMITTING TO A BRANCH} + . qq{ NOT OWNED BY YOU.\n} + . qq{*** Please ensure that you have the} + . qq{ owner's permission.\n\n} + . qq{Would you like to commit this change?}, + CI_TRUNK => qq{\n} + . qq{*** WARNING: YOU ARE COMMITTING TO THE TRUNK.\n} + . qq{*** Please ensure that your change conforms to} + . qq{ your project's working practices.\n\n} + . qq{Would you like to commit this change?}, + CONTINUE => qq{Are you sure you want to continue?}, + MERGE => qq{Would you like to go ahead with the merge?}, + MERGE_REV => qq{Please enter the revision you wish to merge from}, + MKPATCH_OVERWRITE => qq{%s: output location exists. OK to overwrite?}, + RUN_SVN_COMMAND => qq{Would you like to run "svn %s"?}, +); + +# List of CLI warning messages +our %CLI_MESSAGE_FOR_WARNING = ( + BRANCH_SUBDIR => "%s: is a sub-directory of a branch in a FCM project.\n", + CF_BINARY => "%s: ignoring binary file, please resolve manually.\n", + INVALID_BRANCH => $CLI_MESSAGE_FOR_ERROR{INVALID_BRANCH}, + ST_IN_TRAC_DIFF => "%s: local changes cannot be displayed in Trac.\n" +); + +# CLI prompt handler and title prefix +our $CLI_PROMPT = \&_cli_prompt; +our $CLI_PROMPT_PREFIX = q{fcm }; + +# List of exception handlers [$class, CODE->($function, $e)] +our @CLI_EXCEPTION_HANDLERS = ( + ['Fcm::CLI::Exception', \&_cli_e_handler_of_cli_exception], + ['Fcm::Cm::Exception' , \&_cli_e_handler_of_cm_exception], + ['Fcm::Cm::Abort' , \&_cli_e_handler_of_cm_abort], +); + +# Event handlers +our %CLI_HANDLER_OF = ( + 'WC_STATUS' => \&_cli_handler_of_wc_status, + 'WC_STATUS_PATH' => \&_cli_handler_of_wc_status_path, +); + +# Handlers of sub-commands +our %CLI_IMPL_OF = ( + 'add' => \&_cli_command_add, + 'branch' => \&cm_branch, + 'commit' => \&cm_commit, + 'conflicts' => \&cm_conflicts, + 'checkout' => \&_cli_command_checkout, + 'delete' => \&_cli_command_delete, + 'diff' => \&cm_diff, + 'merge' => \&cm_merge, + 'mkpatch' => \&cm_mkpatch, + 'switch' => \&_cli_command_switch, + 'update' => \&_cli_command_update, +); + +# List of overridden subcommands that need to display "svn help" +our %CLI_MORE_HELP_FOR = map {($_, 1)} qw{add diff delete switch update}; + +# The preferred name of subcommand aliases +our %CLI_PREFERRED_NAME_OF = ( + 'ann' => 'blame', + 'annotate' => 'blame', + 'br' => 'branch', + 'ci' => 'commit', + 'cf' => 'conflicts', + 'co' => 'checkout', + 'cp' => 'copy', + 'del' => 'delete', + 'di' => 'diff', + 'ls' => 'list', + 'mv' => 'move', + 'pd' => 'propdel', + 'pdel' => 'propdel', + 'pe' => 'propedit', + 'pedit' => 'propedit', + 'pg' => 'propget', + 'pget' => 'propget', + 'pl' => 'proplist', + 'plist' => 'proplist', + 'praise' => 'blame', + 'ps' => 'propset', + 'pset' => 'propset', + 'remove' => 'delete', + 'ren' => 'move', + 'rename' => 'move', + 'rm' => 'delete', + 'sw' => 'switch', + 'up' => 'update', +); + +# List of subcommands that accept URL inputs +our %CLI_SUBCOMMAND_URL = map {($_, 1)} qw{ + blame + branch + cat + checkout + copy + delete + diff + export + import + info + list + lock + log + merge + mkdir + mkpatch + move + propdel + propedit + propget + proplist + propset + switch + unlock +}; + +# List of subcommands that accept revision inputs +our %CLI_SUBCOMMAND_REV = map {($_, 1)} qw{ + blame + branch + cat + checkout + copy + diff + export + info + list + log + merge + mkpatch + move + propdel + propedit + propget + proplist + propset + switch +}; + +# Common patterns +our %PATTERN_OF = ( + # A CLI option + CLI_OPT => qr{ + \A (?# beginning) + (--\w[\w-]*=) (?# capture 1, a long option label) + (.*) (?# capture 2, the value of the option) + \z (?# end) + }xms, + # A CLI revision option + CLI_OPT_REV => qr{ + \A (?# beginning) + (--revision(?:=|\z)|-r) (?# capture 1, --revision, --revision= or -r) + (.*) (?# capture 2, trailing value) + \z (?# end) + }xms, + # A CLI revision option range + CLI_OPT_REV_RANGE => qr{ + \A (?# beginning) + ( (?# capture 1, begin) + (?:\{[^\}]+\}+) (?# a date in curly braces) + | (?# or) + [^:]+ (?# anything but a colon) + ) (?# capture 1, end) + (?::(.*))? (?# colon, and capture 2 til the end) + \z (?# end) + }xms, + # A FCM branch path look-alike, should be configurable in the future + FCM_BRANCH_PATH => qr{ + \A (?# beginning) + /* (?# some slashes) + (?: (?# group 1, begin) + (?:trunk/*(?:@\d+)?\z) (?# trunk at a revision) + | (?# or) + (?:trunk|branches|tags)/+ (?# trunk, branch or tags) + ) (?# group 1, end) + }xms, + # Last line of output from "svn status -u" + ST_AGAINST_REV => qr{ + \A (?# beginning) + Status\sagainst\srevision:.* (?# output of svn status -u) + \z (?# end) + }xms, + # Extract path from "svn status" + ST_PATH => qr{ + \A (?# beginning) + .{6} (?# 6 columns) + \s+ (?# spaces) + (.+) (?# capture 1, target path) + \z (?# end) + }xms, + # A legitimate "svn" revision + SVN_REV => qr{ + \A (?# beginning) + (?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}) (?# digit, reserved words, date) + \z (?# end) + }ixms, +); + +# Status matchers +our %ST_MATCHER_FOR = ( + MISSING => sub {substr($_[0], 0, 1) eq '!'}, + MODIFIED => sub {substr($_[0], 0, 6) =~ qr{\S}xms}, + OUT_OF_DATE => sub {substr($_[0], 7, 1) eq '*'}, + UNKNOWN => sub {substr($_[0], 0, 1) eq '?'}, +); + +# ------------------------------------------------------------------------------ +# Entry function for the FCM code management CLI. Calls the relevant FCM code +# management function or SVN command based on $function. +sub cli { + my ($function, @args) = @_; + if (exists($CLI_PREFERRED_NAME_OF{$function})) { + $function = $CLI_PREFERRED_NAME_OF{$function}; + } + if (grep {$_ eq '-h' || $_ eq '--help'} @args) { + return _cli_help($function, 'NOEXIT'); + } + if (exists($CLI_SUBCOMMAND_URL{$function})) { + _cli_keyword_expand_url(\@args); + } + if (exists($CLI_SUBCOMMAND_REV{$function})) { + _cli_keyword_expand_rev(\@args); + } + if (exists($CLI_IMPL_OF{$function})) { + eval { + local(@ARGV) = @args; + return $CLI_IMPL_OF{$function}->(@args); + }; + if ($@) { + my $e = $@; + for (@CLI_EXCEPTION_HANDLERS) { + my ($class, $handler) = @{$_}; + if ($class->caught($e)) { + return $handler->($function, $e); + } + } + die($e); + } + } + else { + return _svn($function, @args); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_branch (); +# +# DESCRIPTION +# This is a FCM command to check information, create or delete a branch in +# a Subversion repository. +# ------------------------------------------------------------------------------ + +sub cm_branch { + # Process command line options + # ---------------------------------------------------------------------------- + my ( + $info, + $delete, + $create, + $list, + $branch_of_branch, + $name, + $non_interactive, + $password, + $rev, + $rev_flag, + $show_all, + $show_children, + $show_other, + $show_siblings, + $svn_non_interactive, + @tickets, + $type, + @userlist, + $verbose, + ); + my $rc = GetOptions( + 'info|i' => \$info, + 'delete|d' => \$delete, + 'create|c' => \$create, + 'list|l' => \$list, + 'branch-of-branch' => \$branch_of_branch, + 'name|n=s' => \$name, + 'non-interactive' => \$non_interactive, + 'password=s' => \$password, + 'revision|r=s' => \$rev, + 'rev-flag=s' => \$rev_flag, + 'show-all|a' => \$show_all, + 'show-children' => \$show_children, + 'show-other' => \$show_other, + 'show-siblings' => \$show_siblings, + 'svn-non-interactive' => \$svn_non_interactive, + 'ticket|k=s' => \@tickets, + 'type|t=s' => \$type, + 'user|u=s' => \@userlist, + 'verbose|v' => \$verbose, + ); + if (!$rc) { + _cli_err(); + } + + my $num_options = 0; + $num_options++ if defined $info; + $num_options++ if defined $delete; + $num_options++ if defined $create; + $num_options++ if defined $list; + if ($num_options > 1) { + _cli_err(); + } + + # Get URL of repository or branch + # ---------------------------------------------------------------------------- + my $url; + if ($ARGV[0]) { + $url = Fcm::CmUrl->new (URL => $ARGV[0]); + + if (not $url->is_url) { + # An argument is specified and is not a URL + # Assume that it is a path with a working copy + if (&is_wc ($ARGV[0])) { + $url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0])); + + } else { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $ARGV[0]); + } + } + + } else { + # An argument is not specified + # Assume that the current directory is a working copy + if (&is_wc ()) { + $url = Fcm::CmUrl->new (URL => &get_url_of_wc ()); + + } else { + return _cm_err(Fcm::Cm::Exception->INVALID_TARGET, '.'); + } + } + + # Ensure $url->url_peg is a URL of a standard FCM project + if (!$url->project_url()) { + return _cm_err(Fcm::Cm::Exception->INVALID_PROJECT, $url->url_peg()); + } + + if ($create) { + # The --create option is specified, create a branch + # -------------------------------------------------------------------------- + + # Check branch type flags + if ($type) { + $type = uc ($type); + + if ($type =~ /^(USER|SHARE)$/) { + $type = 'DEV' . $Fcm::Config::DELIMITER . $1; + + } elsif ($type =~ /^(CONFIG|REL)$/) { + $type = 'PKG' . $Fcm::Config::DELIMITER . $1; + + } elsif ($type =~ /^(DEV|TEST|PKG)$/) { + $type = $1 . $Fcm::Config::DELIMITER . 'USER'; + + } elsif ($type !~ /^(?:DEV|TEST|PKG)$Fcm::Config::DELIMITER(?:USER|SHARE)$/ + and $type !~ /^PKG$Fcm::Config::DELIMITER(?:CONFIG|REL)/) { + _cli_err('CLI_OPT_ARG', 'type', $type); + } + + } else { + $type = 'DEV' . $Fcm::Config::DELIMITER . 'USER'; + } + + # Check branch name + if (!$name) { + _cli_err('CLI_OPT_WITH_OPT', 'name', 'create'); + } + + if ($name !~ qr{\A[\w.-]+\z}xms) { + _cli_err('CLI_OPT_ARG', 'name', $name); + } + + # Check revision flag is valid + if ($rev_flag) { + $rev_flag = uc ($rev_flag); + if ($rev_flag !~ qr{\A (?:NORMAL|NUMBER|NONE) \z}xms) { + _cli_err('CLI_OPT_ARG', 'rev-flag', $rev_flag); + } + + } else { + $rev_flag = 'NORMAL'; + } + + # Handle multiple tickets + @tickets = split ( + /$Fcm::Config::DELIMITER_LIST/, + join ($Fcm::Config::DELIMITER_LIST, @tickets) + ); + s/^#// for (@tickets); + @tickets = sort {$a <=> $b} @tickets; + + # Determine whether to create a branch of a branch + $url->branch ('trunk') unless $branch_of_branch; + + # Create the branch + my $branch = Fcm::CmBranch->new; + $branch->create ( + SRC => $url, + TYPE => $type, + NAME => $name, + PASSWORD => $password, + REV_FLAG => $rev_flag, + TICKET => \@tickets, + REV => $rev, + NON_INTERACTIVE => $non_interactive, + SVN_NON_INTERACTIVE => $svn_non_interactive, + ); + + } elsif ($list) { + # The option --list is specified + # List branches owned by current or specified users + # -------------------------------------------------------------------------- + # Get URL of the project "branches/" sub-directory + $url->subdir (''); + $url->branch (''); + + my @branches = $url->branch_list($rev); + if (!$show_all) { + @userlist = split(qr{:}xms, join(q{:}, @userlist)); + if (!@userlist) { + @userlist = (Fcm::Config->instance()->user_id()); + } + my %filter = map {($_, 1)} @userlist; + @branches = grep { + $filter{Fcm::CmBranch->new(URL => $_)->branch_owner()} + } @branches + } + + # Output, number of branches found + $CLI_MESSAGE->( + 'BRANCH_LIST', + $url->project_url_peg(), + $rev ? "r$rev" : 'HEAD', + scalar(@branches), + ($show_all ? '[--show-all]' : join(q{, }, sort(@userlist))), + ); + + if (@branches) { + # Output the URL of each branch + if (not $verbose) { + my $project = $url->project_url; + @branches = map {Fcm::Keyword::unexpand($_)} @branches; + } + @branches = map {$_ . "\n"} sort @branches; + $CLI_MESSAGE->(q{}, join(q{}, @branches)); + + } else { + # No branch found, exit with an error code + return; + } + + } else { + # The option --info or --delete is specified + # Report branch information (and/or delete a branch) + # -------------------------------------------------------------------------- + # Set verbose level + Fcm::Config->instance()->verbose ($verbose ? 1 : 0); + + # Set up the branch, report any error + my $branch = Fcm::CmBranch->new (URL => $url->url_peg); + if (!$branch->branch()) { + return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $branch->url_peg()); + } + if (!$branch->url_exists()) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $branch->url_peg()); + } + + # Remove the sub-directory part of the URL + $branch->subdir (''); + + # Report branch info + $branch->display_info ( + SHOW_CHILDREN => ($show_all || $show_children), + SHOW_OTHER => ($show_all || $show_other ), + SHOW_SIBLINGS => ($show_all || $show_siblings), + ); + + # Delete branch if --delete is specified + $branch->del ( + PASSWORD => $password, + NON_INTERACTIVE => $non_interactive, + SVN_NON_INTERACTIVE => $svn_non_interactive, + ) if $delete; + } + +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_commit (); +# +# DESCRIPTION +# This is a FCM wrapper to the "svn commit" command. +# ------------------------------------------------------------------------------ + +sub cm_commit { + my ($dry_run, $svn_non_interactive, $password); + my $rc = GetOptions( + 'dry-run' => \$dry_run, + 'svn-non-interactive' => \$svn_non_interactive, + 'password=s' => \$password, + ); + if (!$rc) { + _cli_err(); + } + + # The remaining argument is the path to a working copy + my ($path) = @ARGV; + + if ($path) { + if (!-e $path) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path); + } + + } else { + # No argument specified, use current working directory + $path = cwd (); + } + + # Make sure we are in a working copy + if (!is_wc($path)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); + } + + # Make sure we are at the top level of the working copy + # (otherwise we might miss any template commit message) + my $dir = &get_wct ($path); + + if ($dir ne cwd ()) { + chdir($dir) || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir); + $CLI_MESSAGE->('CHDIR_WCT', $dir); + } + + # Get update status of working copy + # Check working copy files are not in conflict, missing, or out of date + my @status = _svn_status_get([], 1); + unless (defined $dry_run) { + my (@conflict, @missing, @outdate); + + for (@status) { + if (/^C/) { + push @conflict, $_; + next; + } + + if (/^!/) { + push @missing, $_; + next; + } + + if (/^.{7}\*/) { + push @outdate, $_; + next; + } + + # Check that all files which have been added have the svn:executable + # property set correctly (in case the developer adds a script before they + # remember to set the execute bit) + next unless /^A.{7} *\d+ +(.*)/; + my $file = $1; + + next unless -f $file; + my ($command, @arguments) + = (-x $file && !-l $file) ? ('propset', '*') : ('propdel'); + run_command(['svn', $command, qw{-q svn:executable}, @arguments, $file]); + } + + # Abort commit if files are in conflict, missing, or out of date + if (@conflict or @missing or @outdate) { + for ( + ['ST_CONFLICT' , \@conflict], + ['ST_MISSING' , \@missing ], + ['ST_OUT_OF_DATE', \@outdate ], + ) { + my ($key, $array_ref) = @{$_}; + if (@{$array_ref}) { + $CLI_MESSAGE->($key, join(q{}, @{$array_ref})); + } + } + return _cm_abort(Fcm::Cm::Abort->FAIL); + } + } + + # Read in any existing message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->read_file; + + # Execute "svn status" for a list of changed items + @status = grep !/^\?/, _svn_status_get(); + + # Abort if there is no change in the working copy + if (!@status) { + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + # Get associated URL of current working copy + my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ()); + + # Include URL, or project, branch and sub-directory info in @status + unshift @status, "\n"; + + if ($url->project and $url->branch) { + unshift @status, ( + '[Project: ' . $url->project . ']' . "\n", + '[Branch : ' . $url->branch . ']' . "\n", + '[Sub-dir: ' . ($url->subdir ? $url->subdir : '') . ']' . "\n", + ); + + } else { + unshift @status, '[URL: ' . $url->url . ']' . "\n"; + } + + # Use a temporary file to store the final commit log message + $ci_mesg->ignore_mesg (\@status); + my $logfile = $ci_mesg->edit_file (TEMP => 1); + + # Check with the user to see if he/she wants to go ahead + my $reply = 'n'; + if (!defined($dry_run)) { + # Add extra warning for trunk commit + my @prompt_args; + my $user = Fcm::Config->instance()->user_id(); + + if ($url->is_trunk()) { + @prompt_args = ('CI_TRUNK'); + } + elsif ($user && $url->is_branch() && $url->branch_owner() ne $user) { + if (exists $Fcm::CmUrl::owner_keywords{$url->branch_owner}) { + @prompt_args = ( + 'CI_BRANCH_SHARED', + uc($Fcm::CmUrl::owner_keywords{$url->branch_owner()}), + ); + } + else { + @prompt_args = ('CI_BRANCH_USER'); + } + } + else { + @prompt_args = ('CI'); + } + $reply = $CLI_PROMPT->('commit', @prompt_args); + } + + if ($reply eq 'y') { + # Commit the change if user replies "y" for "yes" + my @command = ( + qw/svn commit -F/, $logfile, + ($svn_non_interactive ? '--non-interactive' : ()), + (defined $password ? ('--password', $password) : ()), + ); + my $rc; + &run_command (\@command, RC => \$rc, ERROR => 'warn'); + + if ($rc) { + # Commit failed + # Write temporary commit log content to commit log message file + $ci_mesg->write_file; + + # Fail the command + return _cm_abort(Fcm::Cm::Abort->FAIL); + } + + # Remove commit message file + unlink $ci_mesg->file; + + # Update the working copy + $CLI_MESSAGE->(q{}, join(q{}, _svn_update())); + + } else { + $ci_mesg->write_file; + if (!$dry_run) { + return _cm_abort(); + } + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_conflicts (); +# +# DESCRIPTION +# This is a FCM command for resolving conflicts within working copy using a +# graphical merge tool. +# ------------------------------------------------------------------------------ + +sub cm_conflicts { + # Path to the working copy + my $path = $ARGV[0]; + $path = cwd () if not $path; + + # Check for any files with conflicts + my @status = grep /^C.{4} *(.*)/, &run_command ( + [qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx', + ); + my @files = map {m/^C.{4} *(.*)/; $1} @status; + + # Save current working directory + my $topdir = cwd (); + + # Set up environment for graphical merge + # Use environment variable if set, otherwise use default setting + local(%ENV) = %ENV; + $ENV{FCM_GRAPHIC_MERGE} + ||= Fcm::Config->instance()->setting (qw/TOOL GRAPHIC_MERGE/); + + FILE: + for my $file (@files) { + # Print name of file in conflicts + $CLI_MESSAGE->('CF', $file); + + # Determine directory and base name of file in conflicts + my $base = basename $file; + my $dir = dirname $file; + + # Change to container directory of file in conflicts + chdir(File::Spec->catfile($topdir, $dir)) + || return _cm_err(Fcm::Cm::Exception->CHDIR, $dir); + + # Use "svn info" to determine conflict marker files + my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx'); + + # Ignore if $base is a binary file + if (-B $base) { + $CLI_MESSAGE->('CF_BINARY', $base); + next FILE; + } + + # Get conflicts markers files + my ($older, $mine, $yours); + + for (@info) { + $older = $1 if (/^Conflict Previous Base File: (.*)/); + $mine = $1 if (/^Conflict Previous Working File: (.*)/); + $yours = $1 if (/^Conflict Current Base File: (.*)/); + } + + if (-f $base and (stat $base)[9] > (stat $mine)[9] + 1) { + # If $base is newer (by more than a second), it may contain saved changes + if ($CLI_PROMPT->('conflicts', 'CF_OVERWRITE', $base) ne 'y') { + next FILE; + } + } + + # Launch graphic merge tool + my $rc; + my $command = [qw/fcm_graphic_merge/, $base, $mine, $older, $yours]; + # $rc == 0: all conflicts resovled + # $rc == 1: some conflicts not resolved + # $rc == 2: trouble + eval { + run_command($command, RC => \$rc); + }; + if ($@) { + if (!defined($rc) || $rc > 1) { + die($@); + } + } + next FILE if $rc; + + # Prompt user to run "svn resolved" on the file + if ($CLI_PROMPT->('conflicts', 'RUN_SVN_COMMAND', 'resolved') eq 'y') { + run_command([qw{svn resolved}, $base]); + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_diff (); +# +# DESCRIPTION +# This is a wrapper to "svn diff". It adds two extra functionalities. The +# first one allows the command to show differences relative to the base of +# the branch. The second one allows differences to be displayed via a +# graphical tool. +# ------------------------------------------------------------------------------ + +sub cm_diff { + # Set up environment for graphical diff + # Use environment variable if set, otherwise use default setting + local(%ENV) = %ENV; + $ENV{FCM_GRAPHIC_DIFF} + ||= Fcm::Config->instance()->setting(qw/TOOL GRAPHIC_DIFF/); + + # Check for the --branch options + # ---------------------------------------------------------------------------- + my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV; + + if (not $branch) { + # The --branch option not specified, just call "svn diff" + # Convert the --graphical to qw/--diff-cmd fcm_graphical_diff/ + # Convert the --summarise to --summarize + @ARGV = map { + my @return; + if ($_ eq '-g' or $_ eq '--graphical') { + @return = (qw/--diff-cmd fcm_graphic_diff/) + + } elsif ($_ eq '--summarise') { + @return = ('--summarize'); + + } else { + @return = ($_); + } + @return; + } @ARGV; + + # Execute the command + return _svn('diff', @ARGV); + } + + # The --branch option is specified + # ---------------------------------------------------------------------------- + + # Determine whether the --graphical option is specified, + # if so set the appropriate command + # ---------------------------------------------------------------------------- + my ($diff_cmd, $extensions, $graphical, $summarise, $trac, $wiki); + my $rc = GetOptions ( + 'b|branch' => \$branch, + 'diff-cmd=s' => \$diff_cmd, + 'x|extensions=s' => \$extensions, + 'g|graphical' => \$graphical, + 'summarise|summarize' => \$summarise, + 't|trac' => \$trac, + 'wiki' => \$wiki, + ); + if (!$rc) { + _cli_err(); + } + + my @diff_cmd = (); + + if ($graphical) { + @diff_cmd = (qw/--diff-cmd fcm_graphic_diff/); + + } elsif ($diff_cmd) { + @diff_cmd = ('--diff-cmd', $diff_cmd); + + push @diff_cmd, '--extensions', split (/\s+/, $extensions) if $extensions; + } + + # The remaining argument should either be a URL or a PATH + my ($url_arg, $path_arg); + + if (@ARGV) { + my $arg = Fcm::CmUrl->new (URL => $ARGV[0]); + + if ($arg->is_url) { + $url_arg = $ARGV[0]; + + } else { + $path_arg = $ARGV[0]; + } + } + + # Get repository and branch information + # ---------------------------------------------------------------------------- + my ($url, $path); + if (defined $url_arg) { + # If a URL is specified, get repository and branch information from it + $url = Fcm::CmBranch->new (URL => $url_arg); + + } else { + # Get repository and branch information from the specified path or the + # current directory if it is a working copy + $path = $path_arg ? $path_arg : cwd (); + if (!is_wc($path)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); + } + + $url = Fcm::CmBranch->new (URL => &get_url_peg_of_wc ($path)); + } + + # Check that URL is a standard FCM branch + if (!$url->is_branch()) { + return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $url->url_peg()); + } + + # Save and remove sub-directory part of the URL + my $subdir = $url->subdir (); + $url->subdir (''); + + # Check that $url exists + if (!$url->url_exists()) { + return _cm_err(Fcm::Cm::Exception->INVALID_URL, $url->url_peg()); + } + + # Compare current branch with its parent + # ---------------------------------------------------------------------------- + my $parent = Fcm::CmBranch->new (URL => $url->parent->url); + $parent->pegrev ($url->pegrev) if $url->pegrev; + + if (!$parent->url_exists()) { + return _cm_err( + Fcm::Cm::Exception->PARENT_NOT_EXIST, $url->url_peg(), $parent->url(), + ); + } + + my $base = $parent->base_of_merge_from ($url); + + # Ensure the correct diff (syntax) is displayed + # ---------------------------------------------------------------------------- + # Reinstate the sub-tree part into the URL + $url->subdir ($subdir); + $base->subdir ($subdir); + + # Ensure the branch URL has a peg revision + $url->pegrev ($url->svninfo (FLAG => 'Last Changed Rev')) if not $url->pegrev; + + if ($trac or $wiki) { + # Trac/wiki + # -------------------------------------------------------------------------- + if (!$url_arg && _svn_status_get([$path_arg ? $path_arg : q{.}])) { + $CLI_MESSAGE->('ST_IN_TRAC_DIFF', ($path_arg ? $path_arg : q{.})); + } + + # Trac wiki syntax + my $wiki_syntax = 'diff:' . $base->path_peg . '//' . $url->path_peg; + + if ($wiki) { + # Print Trac wiki syntax only + $CLI_MESSAGE->(q{}, "$wiki_syntax\n"); + + } else { # if $trac + # Use Trac to view "diff" + my $browser = Fcm::Config->instance()->setting(qw/WEB_BROWSER/); + $browser ||= 'firefox'; + + my $trac_url = Fcm::Keyword::get_browser_url($url->project_url()); + $trac_url =~ s{/intertrac/.*$}{/intertrac/$wiki_syntax}xms; + + &run_command ([$browser, $trac_url], METHOD => 'exec', PRINT => 1); + } + + } else { + # Execute the "diff" command + # -------------------------------------------------------------------------- + my @command = ( + qw/svn diff/, @diff_cmd, + ($summarise ? ('--summarize') : ()), + '--old', $base->url_peg, + '--new', ($url_arg ? $url->url_peg : ($path_arg ? $path_arg : '.')), + ); + &run_command (\@command, PRINT => 1); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_merge (); +# +# DESCRIPTION +# This is a wrapper to "svn merge". +# ------------------------------------------------------------------------------ + +sub cm_merge { + # Options + # ---------------------------------------------------------------------------- + my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose); + my $rc = GetOptions( + 'custom' => \$custom, + 'dry-run' => \$dry_run, + 'non-interactive' => \$non_interactive, + 'reverse' => \$reverse, + 'revision|r=s' => \$rev, + 'verbose|v' => \$verbose, + ); + if (!$rc) { + _cli_err(); + } + + # Find out the URL of the working copy + # ---------------------------------------------------------------------------- + my ($target, $wct); + if (&is_wc ()) { + $wct = &get_wct (); + + if ($wct ne cwd ()) { + chdir($wct) || return _cm_err(Fcm::Cm::Exception->CHDIR, $wct); + $CLI_MESSAGE->('CHDIR_WCT', $wct); + } + + $target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct)); + + } else { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, '.'); + } + + if (!$target->url_exists()) { + return _cm_err(Fcm::Cm::Exception->WC_URL_NOT_EXIST, '.'); + } + + # The target must be at the top of a branch + # $subdir will be used later to determine whether the merge is allowed or not + my $subdir = $target->subdir; + $target->subdir ('') if $subdir; + + # Check for any local modifications + # ---------------------------------------------------------------------------- + if (!$dry_run && !$non_interactive) { + _svn_status_checker('merge', 'MODIFIED', $CLI_HANDLER_OF{WC_STATUS})->(); + } + + # Determine the SOURCE URL + # ---------------------------------------------------------------------------- + my $source; + + if ($reverse) { + # Reverse merge, the SOURCE is the the working copy URL + $source = Fcm::CmBranch->new (URL => $target->url); + + } else { + # Automatic/custom merge, argument 1 is the SOURCE of the merge + my $source_url = shift (@ARGV); + if (!$source_url) { + _cli_err('CLI_MERGE_ARG1'); + } + + $source = _cm_get_source($source_url, $target); + } + + # Parse the revision option + # ---------------------------------------------------------------------------- + if ($reverse && !$rev) { + _cli_err('CLI_OPT_WITH_OPT', 'revision', 'reverse'); + } + my @revs = (($reverse || $custom) && $rev ? split(qr{:}xms, $rev) : ()); + + # Determine the merge delta and the commit log message + # ---------------------------------------------------------------------------- + my (@delta, $mesg); + my $separator = '-' x 80 . "\n"; + + if ($reverse) { + # Reverse merge + # -------------------------------------------------------------------------- + if (@revs == 1) { + $revs[1] = ($revs[0] - 1); + + } else { + @revs = sort {$b <=> $a} @revs; + } + + $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) + unless $source->pegrev; + $source->subdir ($subdir); + + # "Delta" of the "svn merge" command + @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg); + + # Template message + $mesg = 'Reversed r' . $revs[0] . + (($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' . + $source->path . "\n"; + + } elsif ($custom) { + # Custom merge + # -------------------------------------------------------------------------- + if (@revs) { + # Revision specified + # ------------------------------------------------------------------------ + # Only one revision N specified, use (N - 1):N as the delta + unshift @revs, ($revs[0] - 1) if @revs == 1; + + $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) + unless $source->pegrev; + $source->subdir ($subdir); + $target->subdir ($subdir); + + # "Delta" of the "svn merge" command + @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg); + + # Template message + $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] . + ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n"; + + } else { + # Revision not specified + # ------------------------------------------------------------------------ + # Get second source URL + my $source2_url = shift (@ARGV); + if (!$source2_url) { + _cli_err('CLI_MERGE_ARG2'); + } + + my $source2 = _cm_get_source($source2_url, $target); + + $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev')) + unless $source->pegrev; + $source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev')) + unless $source2->pegrev; + $source->subdir ($subdir); + $source2->subdir ($subdir); + $target->subdir ($subdir); + + # "Delta" of the "svn merge" command + @delta = ($source->url_peg, $source2->url_peg); + + # Template message + $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg . + ' cf. ' . $source2->path_peg . "\n"; + } + + } else { + # Automatic merge + # -------------------------------------------------------------------------- + # Check to ensure source branch is not the same as the target branch + if (!$target->branch()) { + return _cm_err(Fcm::Cm::Exception->WC_INVALID_BRANCH, $wct); + } + if ($source->branch() eq $target->branch()) { + return _cm_err(Fcm::Cm::Exception->MERGE_SELF, $target->url_peg(), $wct); + } + + # Only allow the merge if the source and target are "directly related" + # -------------------------------------------------------------------------- + my $anc = $target->ancestor ($source); + return _cm_err( + Fcm::Cm::Exception->MERGE_UNRELATED, $target->url_peg(), $source->url_peg + ) unless + ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg) + or + ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg) + or + ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url); + + # Check for available merges from the source + # -------------------------------------------------------------------------- + my @revs = $target->avail_merge_from ($source, 1); + + if (@revs) { + if ($verbose) { + # Verbose mode, print log messages of available merges + $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), q{}); + for (@revs) { + $CLI_MESSAGE->('SEPARATOR'); + $CLI_MESSAGE->(q{}, $source->display_svnlog($_)); + } + $CLI_MESSAGE->('SEPARATOR'); + } + else { + # Normal mode, list revisions of available merges + $CLI_MESSAGE->('MERGE_REVS', $source->path_peg(), join(q{ }, @revs)); + } + + } else { + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + # If more than one merge available, prompt user to enter a revision number + # to merge from, default to $revs [0] + # -------------------------------------------------------------------------- + if ($non_interactive || @revs == 1) { + $source->pegrev($revs[0]); + } + else { + my $reply = $CLI_PROMPT->( + {type => q{}, default => $revs[0]}, 'merge', 'MERGE_REV', + ); + if (!defined($reply)) { + return _cm_abort(); + } + # Expand revision keyword if necessary + if ($reply) { + $reply = (Fcm::Keyword::expand($target->project_url(), $reply))[1]; + } + # Check that the reply is a number in the available merges list + if (!grep {$_ eq $reply} @revs) { + return _cm_err(Fcm::Cm::Exception->MERGE_REV_INVALID, $reply) + } + $source->pegrev($reply); + } + + # If the working copy top is pointing to a sub-directory of a branch, + # we need to check whether the merge will result in losing changes made in + # other sub-directories of the source. + if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) { + return _cm_err(Fcm::Cm::Exception->MERGE_UNSAFE, $source->url_peg()); + } + + # Calculate the base of the merge + my $base = $target->base_of_merge_from ($source); + + # $source and $base must take into account the sub-directory + my $s = Fcm::CmBranch->new (URL => $source->url_peg); + my $b = Fcm::CmBranch->new (URL => $base->url_peg); + + $s->subdir ($subdir) if $subdir; + $b->subdir ($subdir) if $subdir; + + # Diagnostic + $CLI_MESSAGE->('MERGE_CF', $s->path_peg(), $b->path_peg()); + + # Delta of the "svn merge" command + @delta = ($b->url_peg, $s->url_peg); + + # Template message + $mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg . + ' cf. ' . $base->path_peg . "\n"; + } + + # Run "svn merge" in "--dry-run" mode to see the result + # ---------------------------------------------------------------------------- + my @out = &run_command ( + [qw/svn merge --dry-run/, @delta], + METHOD => 'qx', PRINT => ($dry_run and $verbose), + ); + + # Abort merge if it will result in no change + if (not @out) { + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + # Report result of "svn merge --dry-run" + if ($dry_run || !$non_interactive) { + $CLI_MESSAGE->('MERGE_DRY'); + $CLI_MESSAGE->('SEPARATOR'); + $CLI_MESSAGE->(q{}, join(q{}, @out)); + $CLI_MESSAGE->('SEPARATOR'); + } + + return if $dry_run; + + # Prompt the user to see if (s)he would like to go ahead + # ---------------------------------------------------------------------------- + # Go ahead with merge only if user replies "y" + if (!$non_interactive && $CLI_PROMPT->('merge', 'MERGE') ne 'y') { + return _cm_abort(); + } + $CLI_MESSAGE->('MERGE'); + run_command([qw/svn merge/, @delta], PRINT => $verbose); + + # Prepare the commit log + # ---------------------------------------------------------------------------- + # Read in any existing message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->read_file; + $ci_mesg->auto_mesg ([$mesg, @{ $ci_mesg->auto_mesg }]); + $ci_mesg->write_file; + + if ($verbose) { + $CLI_MESSAGE->('SEPARATOR'); + $CLI_MESSAGE->('MERGE_CI', $mesg); + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &Fcm::Cm::cm_mkpatch (); +# +# DESCRIPTION +# This is a FCM command to create a patching script from particular revisions +# of a URL. +# ------------------------------------------------------------------------------ + +sub cm_mkpatch { + # Process command line options and arguments + # ---------------------------------------------------------------------------- + my (@exclude, $organisation, $revision); + my $rc = GetOptions( + 'exclude=s' => \@exclude, + 'organisation=s' => \$organisation, + 'r|revision=s' => \$revision, + ); + if (!$rc) { + _cli_err(); + } + + # Excluded paths, convert glob into regular patterns + @exclude = split (/:/, join (':', @exclude)); + for (@exclude) { + s#\*#[^/]*#; # match any number of non-slash character + s#\?#[^/]#; # match a non-slash character + s#/*$##; # remove trailing slash + } + + # Organisation prefix + $organisation = $organisation ? $organisation : 'original'; + + # Make sure revision option is set correctly + my @revs = $revision ? split (/:/, $revision) : (); + @revs = @revs [0, 1] if @revs > 2; + + # Arguments + my ($u, $outdir) = @ARGV; + + if (!$u) { + _cli_err(); + } + + my $url = Fcm::CmUrl->new (URL => $u); + if (!$url->is_url()) { + return _cm_err(Fcm::Cm::Exception->INVALID_URL, $u); + } + if (!$url->url_exists()) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $u); + } + if (!$url->branch()) { + $CLI_MESSAGE->('INVALID_BRANCH', $u); + } + elsif ($url->subdir()) { + $CLI_MESSAGE->('BRANCH_SUBDIR', $u); + } + + if (@revs) { + # If HEAD revision is given, convert it into a number + # -------------------------------------------------------------------------- + for my $rev (@revs) { + $rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD'; + } + + } else { + # If no revision is given, use the HEAD + # -------------------------------------------------------------------------- + $revs[0] = $url->svninfo (FLAG => 'Revision'); + } + + $revs[1] = $revs[0] if @revs == 1; + + # Check that output directory is set + # ---------------------------------------------------------------------------- + $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir; + + if (-e $outdir) { + # Ask user to confirm removal of old output directory if it exists + if ($CLI_PROMPT->('mkpatch', 'MKPATCH_OVERWRITE') ne 'y') { + return _cm_abort(); + } + + rmtree($outdir) || return _cm_err(Fcm::Cm::Exception->RMTREE, $outdir); + } + + # (Re-)create output directory + mkpath($outdir) || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir); + $CLI_MESSAGE->('OUT_DIR', $outdir); + + # Get and process log of URL + # ---------------------------------------------------------------------------- + my @script = (); # main output script + my %log = $url->svnlog (REV => \@revs); + my $url_path = $url->path; + + for my $rev (sort {$a <=> $b} keys %log) { + # Look at the changed paths for each revision + my $use_patch = 1; # OK to use a patch file? + my @paths; + PATH: for my $path (sort keys %{ $log{$rev}{paths} }) { + my $file = $path; + + # Skip paths outside of the branch + next PATH unless $file =~ s#^$url_path/*##; + + # Skip excluded paths + for my $exclude (@exclude) { + if ($file =~ m#^$exclude(?:/*|$)#) { + # Can't use a patch file if any files have been excluded + $use_patch = 0; + next PATH; + } + } + + # Can't use a patch file if any files have been added or replaced + $use_patch = 0 if $log{$rev}{paths}{$path}{action} eq 'A' or + $log{$rev}{paths}{$path}{action} eq 'R'; + + push @paths, $path; + } + + # If a patch is being used, make sure it isn't just property changes + if ($use_patch) { + my @changedpaths; + for my $path (@paths) { + (my $file = $path) =~ s#^$url_path/*##; + if ($log{$rev}{paths}{$path}{action} eq 'M') { + my ($diff) = &run_command ( + [qw/svn diff --no-diff-deleted --summarize -c/, + $rev, $url->url . '/' . $file. '@' . $rev], + METHOD => 'qx'); + next unless $diff =~ /^[A-Z]/; + } + push @changedpaths, $path; + } + @paths = @changedpaths; + } + + next unless @paths; + + # Create the patch using "svn diff" + my @patch = (); + if ($use_patch) { + @patch = &run_command ([qw/svn diff --no-diff-deleted -c/, $rev, + $url->url], METHOD => 'qx'); + if (@patch) { + # Don't use the patch if it may contain subversion keywords + for (@patch) { + $use_patch = 0 if /\$[a-zA-Z:]+ *\$/; + } + } else { + $use_patch = 0; + } + } + + # Create a directory for this revision in the output directory + my $outdir_rev = File::Spec->catfile ($outdir, $rev); + mkpath($outdir_rev) + || return _cm_err(Fcm::Cm::Exception->MKPATH, $outdir_rev); + + # Parse commit log message + my @msg = split /\n/, $log{$rev}{msg}; + for (@msg) { + # Re-instate line break + $_ .= "\n"; + + # Remove line if it matches a merge template + $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/; + $_ = '' if /^Custom merge into \S+:.+$/; + $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/; + + # Modify Trac ticket link + s/(?:#|ticket:)(\d+)/${organisation}_ticket:$1/g; + + # Modify Trac changeset link + s/(?:r|changeset:)(\d+)/${organisation}_changeset:$1/g; + s/\[(\d+)\]/${organisation}_changeset:$1/g; + } + + push @msg, '(' . $organisation . '_changeset:' . $rev . ')' . "\n"; + + # Write commit log message in a file + my $f_revlog = File::Spec->catfile ($outdir_rev, 'log-message'); + open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')'; + print FILE @msg; + close FILE or die $f_revlog, ': cannot close (', $!, ')'; + + # Handle each changed path + my $export_file = 1; # name for next exported file (gets incremented) + my $patch_needed = 0; # is a patch file required? + my @before_script = (); # patch script to run before patch applied + my @after_script = (); # patch script to run after patch applied + my @copied_dirs = (); # copied directories + CHANGED: for my $path (@paths) { + (my $file = $path) =~ s#^$url_path/*##; + my $url_file = $url->url . '/' . $file . '@' . $rev; + + # Skip paths within copied directories + for my $copied_dir (@copied_dirs) { + next CHANGED if $file =~ m#^$copied_dir(?:/*|$)#; + } + + if ($log{$rev}{paths}{$path}{action} eq 'D') { + # Script to delete file + push @after_script, 'svn delete ' . $file; + + } else { + my $export_required = 0; + my $recursive_add = 0; + my $is_newfile = 0; + + # Skip property changes + if ($log{$rev}{paths}{$path}{action} eq 'M') { + my ($diff) = &run_command ( + [qw/svn diff --no-diff-deleted --summarize -c/, + $rev, $url->url . '/' . $file. '@' . $rev], + METHOD => 'qx'); + next CHANGED unless $diff =~ /^[A-Z]/; + } + + # Determine if the file is a directory + my $is_dir = 0; + if ($log{$rev}{paths}{$path}{action} ne 'M') { + my @info = &run_command ([qw/svn info/, $url_file], METHOD => 'qx'); + for (@info) { + if (/^Node Kind: (\w+)/) { + $is_dir = 1 if $1 eq 'directory'; + last; + } + } + } + + # Decide how to treat added files + if ($log{$rev}{paths}{$path}{action} eq 'A') { + # Determine if the file is copied + if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) { + if ($is_dir) { + # A copied directory needs to be treated as a new file, exported + # and added recursively + $is_newfile = 1; + $export_required = 1; + $recursive_add = 1; + push @copied_dirs, $file; + } else { + # History exists for this file + my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'}; + my $copyfrom_rev = $log{$rev}{paths}{$path}{'copyfrom-rev'}; + my $cp_url = Fcm::CmUrl->new ( + URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev, + ); + + if ($copyfrom_path =~ s#^$url_path/*##) { + # File is copied from a file under the specified URL + # Check source exists + $is_newfile = 1 unless $cp_url->url_exists ($rev - 1); + } else { + # File copied from outside of the specified URL + $is_newfile = 1; + + # Check branches can be determined + if ($url->branch and $cp_url->branch) { + + # Follow its history, stop on copy + my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1); + + # "First" revision of the copied file + my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0]; + my %attrib = %{ $cp_log{$cp_rev}{paths}{$cp_url->path} } + if $cp_log{$cp_rev}{paths}{$cp_url->path}; + + # Check whether the "first" revision is copied from elsewhere. + if (exists $attrib{'copyfrom-path'}) { + # If source exists in the specified URL, set up the copy + my $cp_cp_url = Fcm::CmUrl->new ( + URL => $url->root . $attrib{'copyfrom-path'} . '@' . + $attrib{'copyfrom-rev'}, + ); + $cp_cp_url->branch ($url->branch); + if ($cp_cp_url->url_exists ($rev - 1)) { + ($copyfrom_path = $cp_cp_url->path) =~ s#^$url_path/*##; + # Check path is defined - if not it probably means the + # branch doesn't follow the FCM naming convention + $is_newfile = 0 if $copyfrom_path; + } + } + + # Note: The logic above does not cover all cases. However, it + # should do the right thing for the most common case. Even + # where it gets it wrong the file contents should always be + # correct even if the file history is not. + } + } + + # Check whether file is copied from an excluded path + if (not $is_newfile) { + for my $exclude (@exclude) { + if ($copyfrom_path =~ m#^$exclude(?:/*|$)#) { + $is_newfile = 1; + last; + } + } + } + + # Script to copy file, if required + push @before_script, 'svn copy ' . $copyfrom_path . ' ' . $file + if not $is_newfile; + } + + } else { + # History does not exist, must be a new file + $is_newfile = 1; + # If it's a directory then create it (in case patch doesn't) + push @before_script, 'mkdir ' . $file if $is_dir; + } + } + + if ($log{$rev}{paths}{$path}{action} eq 'R') { + # Script to delete file + push @before_script, 'svn delete ' . $file; + + # Now treat as new file + $is_newfile = 1; + } + + # Script to add the file, if required + if ($is_newfile) { + if ($recursive_add) { + push @after_script, 'svn add ' . $file; + } else { + push @after_script, 'svn add --non-recursive ' . $file; + } + } + + # Decide whether the file needs to be exported + if (not $is_dir) { + if (not $use_patch) { + $export_required = 1; + } else { + # Export the file if it is binary + my @mime_type = &run_command + ([qw/svn propget svn:mime-type/, $url_file], METHOD => 'qx'); + for (@mime_type) { + $export_required = 1 if not /^text\//; + } + # Only create a patch file if necessary + $patch_needed = 1 if not $export_required; + } + } + + if ($export_required) { + # Download the file using "svn export" + my $export = File::Spec->catfile ($outdir_rev, $export_file); + &run_command ([qw/svn export -q -r/, $rev, $url_file, $export]); + + # Copy the exported file into the file + push @before_script, + 'cp -r ${fcm_patch_dir}/' . $export_file . ' ' . $file; + $export_file++; + } + } + } + + # Write the patch file + if ($patch_needed) { + my $patchfile = File::Spec->catfile ($outdir_rev, 'patchfile'); + open FILE, '>', $patchfile + or die $patchfile, ': cannot open (', $!, ')'; + print FILE @patch; + close FILE or die $patchfile, ': cannot close (', $!, ')'; + } + + # Add line break to each line in @before_script and @after_script + @before_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} + @before_script if (@before_script); + @after_script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} + @after_script if (@after_script); + + # Write patch script to output + my $out = File::Spec->catfile ($outdir_rev, 'apply-patch'); + open FILE, '>', $out or die $out, ': cannot open (', $!, ')'; + + # Script header + my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/); + print FILE <&2 + exit 1 +fi +if [[ -a "#commit_message#" ]]; then + echo "\$this: existing commit message in "#commit_message#", abort." >&2 + exit 1 +fi + +# Apply the changes +EOF + + # Script content + print FILE @before_script if @before_script; + print FILE "patch -p0 <\${fcm_patch_dir}/patchfile || exit 1\n" + if $patch_needed; + print FILE @after_script if @after_script; + + # Script footer + print FILE <('PATCH_REV', $rev); + } + + # Write the main output script if necessary. Otherwise remove output directory + # ---------------------------------------------------------------------------- + if (@script) { + # Add line break to each line in @script + @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script; + + # Write script to output + my $out = File::Spec->catfile ($outdir, 'fcm-import-patch'); + open FILE, '>', $out or die $out, ': cannot open (', $!, ')'; + + # Script header + my $shell = Fcm::Config->instance()->setting(qw/TOOL SHELL/); + print FILE <&2 + exit 1 +fi + +if [[ \$target == svn://* || \$target == svn+ssh://* || \\ + \$target == http://* || \$target == https://* || \\ + \$target == file://* ]]; then + # A URL, checkout a working copy in a temporary location + fcm_tmp_dir=`mktemp -d \${TMPDIR:=/tmp}/\$this.XXXXXX` + fcm_working_copy=\$fcm_tmp_dir + svn checkout -q \$target \$fcm_working_copy || exit 1 +else + fcm_working_copy=\$target +fi + +# Location of the patches, base on the location of this script +cd `dirname \$0` || exit 1 +fcm_patches_dir=\$PWD + +# Change directory to the working copy +cd \$fcm_working_copy || exit 1 + +# Set the language to avoid encoding problems +export LANG=en_GB + +# Commands to apply patches +EOF + + # Script content + print FILE @script; + + # Script footer + print FILE <('PATCH_DONE', $outdir); + + } else { + # Remove output directory + rmtree $outdir or die $outdir, ': cannot remove'; + + # Diagnostic + return _cm_abort(Fcm::Cm::Abort->NULL); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# CLI: fcm add. +sub _cli_command_add { + my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_; + my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'}); + return ( + @args == @_ ? _svn("add", @args) : cm_check_unknown(\%option, @args) + ); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm checkout. +sub _cli_command_checkout { + if (@ARGV) { + my $target = is_url($ARGV[-1]) ? cwd() : $ARGV[-1]; + if (-d $target && is_wc($target)) { + return _cm_err(Fcm::Cm::Exception->WC_EXIST, $target); + } + } + return _svn('checkout', @ARGV); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm delete. +sub _cli_command_delete { + my @args = map {($_ eq '--check' || $_ eq '-c' ? () : $_)} @_; + my %option = (st_check_handler => $CLI_HANDLER_OF{'WC_STATUS_PATH'}); + return ( + @args == @_ ? _svn("delete", @args) : cm_check_missing(\%option, @args) + ); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm switch. +sub _cli_command_switch { + local(@ARGV) = @_; + if (grep {$_ eq '--relocate'} @ARGV) { + return _svn('switch', @ARGV); + } + my %option; + if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) { + _cli_err(); + } + if (!$option{'non-interactive'}) { + $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS}; + } + if (!@ARGV) { + _cli_err(); + } + $CLI_MESSAGE->(q{}, join(q{}, cm_switch(\%option, @ARGV))); +} + +# ------------------------------------------------------------------------------ +# CLI: fcm update. +sub _cli_command_update { + local(@ARGV) = @_; + my %option; + if (!GetOptions(\%option, 'non-interactive', 'revision|r=s', 'quiet|q')) { + _cli_err(); + } + if (!$option{'non-interactive'}) { + $option{st_check_handler} = $CLI_HANDLER_OF{WC_STATUS}; + } + $CLI_MESSAGE->(q{}, join(q{}, cm_update(\%option, @ARGV))); +} + +# ------------------------------------------------------------------------------ +# CLI error. +sub _cli_err { + my ($key, @args) = @_; + $key ||= 'CLI_USAGE'; + my $message = sprintf($CLI_MESSAGE_FOR_ERROR{$key}, @args); + die(Fcm::CLI::Exception->new({message => $message})); +} + +# ------------------------------------------------------------------------------ +# Handles abort exception. +sub _cli_e_handler_of_cm_abort { + my ($function, $e) = @_; + if ($e->get_code() eq $e->FAIL) { + die(sprintf($CLI_MESSAGE_FOR_ABORT{FAIL}, $function)); + } + else { + $CLI_MESSAGE->($e->get_code(), $function); + } +} + +# ------------------------------------------------------------------------------ +# Handles CM exception. +sub _cli_e_handler_of_cm_exception { + my ($function, $e) = @_; + die(sprintf($CLI_MESSAGE_FOR_ERROR{$e->get_code()}, $e->get_targets())); +} + +# ------------------------------------------------------------------------------ +# Handles CLI exception. +sub _cli_e_handler_of_cli_exception { + my ($function, $e) = @_; + $CLI_MESSAGE->('CLI', $e); + $CLI_MESSAGE->('CLI_HELP', $function); +} + +# ------------------------------------------------------------------------------ +# The default handler of the "WC_STATUS" event. +sub _cli_handler_of_wc_status { + my ($name, $target_list_ref, $status_list_ref) = @_; + if (@{$status_list_ref}) { + $CLI_MESSAGE->('STATUS', join(q{}, @{$status_list_ref})); + if ($CLI_PROMPT->($name, 'CONTINUE') ne 'y') { + return _cm_abort(); + } + } + return @{$status_list_ref}; +} + +# ------------------------------------------------------------------------------ +# The default handler of the "WC_STATUS_PATH" event. +sub _cli_handler_of_wc_status_path { + my ($name, $target_list_ref, $status_list_ref) = @_; + $CLI_MESSAGE->(q{}, join(q{}, @{$status_list_ref})); + my @paths = map {chomp(); ($_ =~ $PATTERN_OF{ST_PATH})} @{$status_list_ref}; + my @paths_of_interest; + while (my $path = shift(@paths)) { + my %handler_of = ( + a => sub {push(@paths_of_interest, $path, @paths); @paths = ()}, + n => sub {}, + y => sub {push(@paths_of_interest, $path)}, + ); + my $reply = $CLI_PROMPT->( + {type => 'yna'}, $name, 'RUN_SVN_COMMAND', "$name $path", + ); + $handler_of{$reply}->(); + } + return @paths_of_interest; +} + +# ------------------------------------------------------------------------------ +# Prints help for a given $subcommand. +sub _cli_help { + my ($key, $exit_val) = @_; + my $pod + = File::Spec->catfile(dirname($INC{'Fcm/Cm.pm'}), 'CLI', "fcm-$key.pod"); + my $has_pod = -f $pod; + if ($has_pod) { + pod2usage({ + '-exitval' => defined($exit_val) ? $exit_val : 2, + '-input' => $pod, + '-verbose' => 1, + }); + } + if (!$has_pod || exists($CLI_MORE_HELP_FOR{$key})) { + local(@ARGV) = ($key); + return _svn('help', $key); + } +} + +# ------------------------------------------------------------------------------ +# Expands location keywords in a list. +sub _cli_keyword_expand_url { + my ($arg_list_ref) = @_; + ARG: + for my $arg (@{$arg_list_ref}) { + my ($label, $value) = ($arg =~ $PATTERN_OF{CLI_OPT}); + if (!$label) { + ($label, $value) = (q{}, $arg); + } + if (!$value) { + next ARG; + } + eval { + $value = Fcm::Util::tidy_url(Fcm::Keyword::expand($value)); + }; + if ($@) { + if ($value ne 'fcm:revision') { + die($@); + } + } + $arg = $label . $value; + } +} + +# ------------------------------------------------------------------------------ +# Expands revision keywords in -r and --revision options in a list. +sub _cli_keyword_expand_rev { + my ($arg_list_ref) = @_; + my @targets; + for my $arg (@{$arg_list_ref}) { + if (-e $arg && is_wc($arg) || is_url($arg)) { + push(@targets, $arg); + } + } + if (!@targets) { + push(@targets, get_url_of_wc()); + } + if (!@targets) { + return; + } + my @old_arg_list = @{$arg_list_ref}; + my @new_arg_list = (); + ARG: + while (defined(my $arg = shift(@old_arg_list))) { + my ($key, $value) = $arg =~ $PATTERN_OF{CLI_OPT_REV}; + if (!$key) { + push(@new_arg_list, $arg); + next ARG; + } + push(@new_arg_list, '--revision'); + if (!$value) { + $value = shift(@old_arg_list); + } + my @revs = grep {defined()} ($value =~ $PATTERN_OF{CLI_OPT_REV_RANGE}); + my ($url, @url_list) = @targets; + for my $rev (@revs) { + if ($rev !~ $PATTERN_OF{SVN_REV}) { + $rev = (Fcm::Keyword::expand($url, $rev))[1]; + } + if (@url_list) { + $url = shift(@url_list); + } + } + push(@new_arg_list, join(q{:}, @revs)); + } + @{$arg_list_ref} = @new_arg_list; +} + +# ------------------------------------------------------------------------------ +# Prints a message. +sub _cli_message { + my ($key, @args) = @_; + for ( + [\*STDOUT, \%CLI_MESSAGE_FOR , q{} ], + [\*STDERR, \%CLI_MESSAGE_FOR_WARNING, q{[WARNING] }], + [\*STDERR, \%CLI_MESSAGE_FOR_ABORT , q{[ABORT] } ], + [\*STDERR, \%CLI_MESSAGE_FOR_ERROR , q{[ERROR] } ], + ) { + my ($handle, $hash_ref, $prefix) = @{$_}; + if (exists($hash_ref->{$key})) { + return printf({$handle} $prefix . $hash_ref->{$key}, @args); + } + } +} + +# ------------------------------------------------------------------------------ +# Wrapper for Fcm::Interactive::get_input. +sub _cli_prompt { + my %option + = (type => 'yn', default => 'n', (ref($_[0]) ? %{shift(@_)} : ())); + my ($name, $key, @args) = @_; + return Fcm::Interactive::get_input( + title => $CLI_PROMPT_PREFIX . $name, + message => sprintf($CLI_MESSAGE_FOR_PROMPT{$key}, @args), + %option, + ); +} + +# ------------------------------------------------------------------------------ +# Check missing status and delete. +sub cm_check_missing { + my %option = %{shift()}; + my $checker + = _svn_status_checker('delete', 'MISSING', $option{st_check_handler}); + my @paths = $checker->(\@_); + if (@paths) { + run_command([qw{svn delete}, @paths]); + } +} + +# ------------------------------------------------------------------------------ +# Check unknown status and add. +sub cm_check_unknown { + my %option = %{shift()}; + my $checker + = _svn_status_checker('add', 'UNKNOWN', $option{st_check_handler}); + my @paths = $checker->(\@_); + if (@paths) { + run_command([qw{svn add}, @paths]); + } +} + +# ------------------------------------------------------------------------------ +# FCM wrapper to SVN switch. +sub cm_switch { + my %option = %{shift()}; + my ($target, $path) = @_; + $path ||= cwd(); + if (!-e $path) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $path); + } + if (!is_wc($path)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $path); + } + + # Check for merge template in the commit log file in the working copy + my $path_of_wc = get_wct($path); + my $ci_mesg = Fcm::CmCommitMessage->new(); + $ci_mesg->dir($path_of_wc); + $ci_mesg->read_file(); + if (@{$ci_mesg->auto_mesg()}) { + return _cm_err( + Fcm::Cm::Exception->SWITCH_UNSAFE, + $path eq $path_of_wc ? $ci_mesg->base() : $ci_mesg->file(), + ); + } + + # Check for any local modifications + if (defined($option{st_check_handler})) { + my $handler = $CLI_HANDLER_OF{WC_STATUS}; + _svn_status_checker('switch', 'MODIFIED', $handler)->([$path_of_wc]); + } + + # Invokes "svn switch" + _svn( + {METHOD => 'qx', PRINT => !$option{quiet}}, + 'switch', + ($option{'non-interactive'} ? '--non-interactive' : ()), + ($option{revision} ? ('-r', $option{revision}) : ()), + ($option{quiet} ? '--quiet' : ()), + _cm_get_source( + $target, + Fcm::CmBranch->new(URL => get_url_of_wc($path_of_wc)), + )->url_peg(), + ($path_of_wc eq cwd() ? () : $path_of_wc), + ); +} + +# ------------------------------------------------------------------------------ +# FCM wrapper to SVN update. +sub cm_update { + my %option = %{shift()}; + my @targets = @_; + if (!@targets) { + @targets = (cwd()); + } + for my $target (@targets) { + if (!-e $target) { + return _cm_err(Fcm::Cm::Exception->NOT_EXIST, $target); + } + if (!is_wc($target)) { + return _cm_err(Fcm::Cm::Exception->INVALID_WC, $target); + } + $target = get_wct($target); + if ($target eq cwd()) { + $target = q{.}; + } + } + if (defined($option{st_check_handler})) { + my ($matcher_keys_ref, $show_updates) + = defined($option{revision}) ? (['MODIFIED' ], undef) + : (['MODIFIED', 'OUT_OF_DATE'], 1 ) + ; + my $matcher = sub { + for my $key (@{$matcher_keys_ref}) { + $ST_MATCHER_FOR{$key}->(@_) && return 1; + } + }; + _svn_status_checker( + 'update', $matcher, $option{st_check_handler}, $show_updates, + )->(\@targets); + } + if ($option{revision} && $option{revision} !~ $PATTERN_OF{SVN_REV}) { + $option{revision} = ( + Fcm::Keyword::expand(get_url_of_wc($targets[0]), $option{revision}) + )[1]; + } + return _svn_update(\@targets, \%option); +} + +# ------------------------------------------------------------------------------ +# Raises an abort exception. +sub _cm_abort { + my ($code) = @_; + $code ||= Fcm::Cm::Abort->USER; + die(bless({code => $code, message => 'abort'}, 'Fcm::Cm::Abort')); +} + +# ------------------------------------------------------------------------------ +# Raises a failure. +sub _cm_err { + my ($code, @targets) = @_; + die(bless( + {code => $code, message => "ERROR: $code", targets => \@targets}, + 'Fcm::Cm::Exception', + )); +} + +# ------------------------------------------------------------------------------ +# Returns the corresponding Fcm::CmBranch instance for $src_url w.r.t. $target. +sub _cm_get_source { + my ($src_url, $target) = @_; + my $source = Fcm::CmBranch->new(URL => $src_url); + if (!$source->is_url()) { + # Not a full URL, construct full URL based on current URL + $source->url_peg($target->url_peg()); + my $project = $target->project(); + my ($path) = $src_url =~ qr{\A/*(.*)\z}xms; + if (index($path, $project) == 0) { + # Argument contains the full path under the repository root + $path = substr($path, length($project)); + } + if ($path =~ $PATTERN_OF{FCM_BRANCH_PATH}) { + # Argument contains the full branch name + $path = join(q{/}, $target->project_path(), $path); + } + else { + # Argument contains the shorter branch name + $path = join(q{/}, $target->project_path(), 'branches', $path); + } + $source->path_peg($path); + } + # Replace source sub-directory with the target sub-directory + $source->subdir($target->subdir()); + # Ensure that the branch name exists + if (!$source->url_exists()) { + return _cm_err(Fcm::Cm::Exception->INVALID_URL, $src_url); + } + # Ensure that the branch name is valid + if (!$source->branch()) { + return _cm_err(Fcm::Cm::Exception->INVALID_BRANCH, $src_url); + } + # Ensure that the source and target URLs are in the same project + if ($source->project_url() ne $target->project_url()) { + return _cm_err( + Fcm::Cm::Exception->DIFF_PROJECTS, + $target->url_peg(), + $source->url_peg(), + ); + } + return $source; +} + +# ------------------------------------------------------------------------------ +# Runs "svn". +sub _svn { + my @args = @_; + my %option; + if (@args && ref($args[0])) { + %option = %{shift(@args)}; + } + return run_command( + ['svn', @args], + PRINT => ($args[0] ne 'cat' && !grep {$_ eq '--xml'} @args), + %option, + ); +} + +# ------------------------------------------------------------------------------ +# Returns the results of "svn status". +sub _svn_status_get { + my ($target_list_ref, $show_updates) = @_; + my @targets = (defined($target_list_ref) ? @{$target_list_ref} : ()); + for my $target (@targets) { + if ($target eq cwd()) { + $target = q{.}; + } + } + my @options = ($show_updates ? qw{--show-updates} : ()); + return _svn({METHOD => 'qx', PRINT => 0}, 'status', @options, @targets); +} + +# ------------------------------------------------------------------------------ +# Returns a "svn status" checker. +sub _svn_status_checker { + my ($name, $matcher, $handler, $show_updates) = @_; + if (!ref($matcher)) { + $matcher = $ST_MATCHER_FOR{$matcher}; + } + return sub { + my ($target_list_ref) = @_; + my @status = _svn_status_get($target_list_ref, $show_updates); + if ($show_updates) { + @status = map {$_ =~ $PATTERN_OF{ST_AGAINST_REV} ? () : $_} @status; + } + my @status_of_interest = grep {$matcher->($_)} @status; + if (defined($handler)) { + return $handler->($name, $target_list_ref, \@status_of_interest); + } + return @status_of_interest; + } +} + +# ------------------------------------------------------------------------------ +# Runs "svn update". +sub _svn_update { + my ($target_list_ref, $option_hash_ref) = @_; + my %option = (defined($option_hash_ref) ? %{$option_hash_ref} : ()); + _svn( + {METHOD => 'qx', PRINT => !$option{quiet}}, + 'update', + ($option{'non-interactive'} ? '--non-interactive' : ()), + ($option{revision} ? ('-r', $option{revision}) : ()), + ($option{quiet} ? '--quiet' : ()), + (defined($target_list_ref) ? @{$target_list_ref} : ()), + ); +} + +# ------------------------------------------------------------------------------ +# Abort exception. +package Fcm::Cm::Abort; +use base qw{Fcm::Exception}; +use constant {FAIL => 'FAIL', NULL => 'NULL', USER => 'USER'}; + +sub get_code { + return $_[0]->{code}; +} + +# ------------------------------------------------------------------------------ +# Resource exception. +package Fcm::Cm::Exception; +our @ISA = qw{Fcm::Cm::Abort}; +use constant { + CHDIR => 'CHDIR', + INVALID_BRANCH => 'INVALID_BRANCH', + INVALID_PROJECT => 'INVALID_PROJECT', + INVALID_TARGET => 'INVALID_TARGET', + INVALID_URL => 'INVALID_URL', + INVALID_WC => 'INVALID_WC', + MERGE_REV_INVALID => 'MERGE_REV_INVALID', + MERGE_SELF => 'MERGE_SELF', + MERGE_UNRELATED => 'MERGE_UNRELATED', + MERGE_UNSAFE => 'MERGE_UNSAFE', + MKPATH => 'MKPATH', + NOT_EXIST => 'NOT_EXIST', + PARENT_NOT_EXIST => 'PARENT_NOT_EXIST', + RMTREE => 'RMTREE', + SWITCH_UNSAFE => 'SWITCH_UNSAFE', + WC_EXIST => 'WC_EXIST', + WC_INVALID_BRANCH => 'WC_INVALID_BRANCH', + WC_URL_NOT_EXIST => 'WC_URL_NOT_EXIST', +}; + +sub get_targets { + return @{$_[0]->{targets}}; +} + +1; +__END__ + +=pod + +=head1 NAME + +Fcm::Cm + +=head1 SYNOPSIS + + use Fcm::Cm qw{cli}; + + # Use as a wrapper to Subversion, and other FCM code management commands + cli('info', '--revision', 'HEAD', $url); + + use Fcm::Cm qw{cm_check_missing cm_check_unknown cm_switch cm_update}; + + # Checks status for "missing" items and "svn delete" them + $missing_st_handler = sub { + my ($name, $target_list_ref, $status_list_ref) = @_; + # ... + return @paths_of_interest; + }; + cm_check_missing({st_check_handler => $missing_st_handler}, @targets); + + # Checks status for "unknown" items and "svn add" them + $unknown_st_handler = sub { + my ($name, $target_list_ref, $status_list_ref) = @_; + # ... + return @paths_of_interest; + }; + cm_check_unknown({st_check_handler => $unknown_st_handler}, @targets); + + # Sets up a status checker + $st_check_handler = sub { + my ($name, $target_list_ref, $status_list_ref) = @_; + # ... + }; + # Switches a "working copy" at the "root" level to a new URL target + cm_switch( + { + 'non-interactive' => $non_interactive_flag, + 'quiet' => $quiet_flag, + 'revision' => $revision, + 'st_check_handler' => $st_check_handler, + }, + $target, $path_of_wc, + ); + # Runs "svn update" on each working copy from their "root" level + cm_update( + { + 'non-interactive' => $non_interactive_flag, + 'quiet' => $quiet_flag, + 'revision' => $revision, + 'st_check_handler' => $st_check_handler, + }, + @targets, + ); + +=head1 DESCRIPTION + +Wraps the Subversion client and implements other FCM code management +functionalities. + +=head1 FUNCTIONS + +=over 4 + +=item cli($function,@args) + +Implements the FCM code management CLI. If --help or -h is specified in @args, +it displays help and returns. Otherwise, it attempts to expand any FCM location +and revision keywords in @args. Calls the relevant FCM code management function +according to $function, or a SVN command if $function is not modified by FCM. + +=item cm_check_missing(\%option,@targets) + +Use "svn status" to check for missing items in @targets. If @targets is an empty +list, the function adds the current working directory to it. Expects +$option{st_check_handler} to be a CODE reference. Calls +$option{st_check_handler} with ($name, $target_list_ref, $status_list_ref) where +$name is "delete", $target_list_ref is \@targets, and $status_list_ref is an +ARRAY reference to a list of "svn status" output with the "missing" status. +$option{st_check_handler} should return a list of interesting paths, which will +be scheduled for removal using "svn delete". + +=item cm_check_unknown(\%option,@targets) + +Similar to cm_check_missing(\%option,@targets) but checks for "unknown" items, +which will be scheduled for addition using "svn add". + +=item cm_switch(\%option,$target,$path_of_wc) + +Invokes "svn switch" at the root of a working copy specified by $path_of_wc (or +the current working directory if $path_of_wc is not specified). +$option{'non-interactive'}, $option{quiet}, $option{revision} determines the +options (of the same name) that are passed to "svn switch". If +$option{st_check_handler} is set, it should be a CODE reference, and will be +called with ('switch', [$path_of_wc], $status_list_ref), where $status_list_ref +is an ARRAY reference to the output returned by "svn status" on $path_of_wc. +This can be used for the application to display the working copy status to the +user before prompting him/her to continue. The return value of +$option{st_check_handler} is ignored. + +=item cm_update(\%option,@targets) + +Invokes "svn update" at the root of each working copy specified by @targets. If +@targets is an empty list, the function adds the current working directory to +it. $option{'non-interactive'}, $option{quiet}, $option{revision} determines the +options (of the same name) that are passed to "svn update". If +$option{st_check_handler} is set, it should be a CODE reference, and will be +called with ($name, $target_list_ref, $status_list_ref), where $name is +'update', $target_list_ref is \@targets and $status_list_ref is an ARRAY +reference to the output returned by "svn status -u" on the @targets. This can be +used for the application to display the working copy update status to the user +before prompting him/her to continue. The return value of +$option{st_check_handler} is ignored. + +=back + +=head1 DIAGNOSTICS + +The following exceptions can be raised: + +=over 4 + +=item Fcm::Cm::Abort + +This exception @ISA L. It is raised if a command +is aborted for some reason. The $e->get_code() method can be used to retrieve an +error code, which can be one of the following: + +=over 4 + +=item $e->FAIL + +The command aborts because of a failure. + +=item $e->NULL + +The command aborts because it will result in no change. + +=item $e->USER + +The command aborts because of an action by the user. + +=back + +=item Fcm::Cm::Exception + +This exception @ISA L. It is raised if a command fails +with a known reason. The $e->get_targets() method can be used to retrieve a list +of targets/resources associated with this exception. The $e->get_code() method +can be used to retrieve an error code, which can be one of the following: + +=over 4 + +=item $e->CHDIR + +Fails to change directory to a target. + +=item $e->INVALID_BRANCH + +A target is not a valid branch URL in the standard FCM project layout. + +=item $e->INVALID_PROJECT + +A target is not a valid project URL in the standard FCM project layout. + +=item $e->INVALID_TARGET + +A target is not a valid Subversion URL or working copy. + +=item $e->INVALID_URL + +A target is not a valid Subversion URL. + +=item $e->INVALID_WC + +A target is not a valid Subversion working copy. + +=item $e->MERGE_REV_INVALID + +An invalid revision (target element 0) is specified for a merge. + +=item $e->MERGE_SELF + +Attempt to merge a URL (target element 0) to its own working copy (target +element 1). + +=item $e->MERGE_UNRELATED + +The merge target (target element 0) is not directly related to the merge source +(target element 1). + +=item $e->MERGE_UNSAFE + +A merge source (target element 0) contains changes outside the target +sub-directory. + +=item $e->MKPATH + +Fail to create a directory (target element 0) recursively. + +=item $e->NOT_EXIST + +A target does not exist. + +=item $e->PARENT_NOT_EXIST + +The parent of the target no longer exists. + +=item $e->RMTREE + +Fail to remove a directory (target element 0) recursively. + +=item $e->SWITCH_UNSAFE + +A merge template exists in the commit message file (target element 0) in a +working copy target. + +=item $e->WC_EXIST + +The target working copy already exists. + +=item $e->WC_INVALID_BRANCH + +The URL of the target working copy is not a valid branch URL in the standard FCM +project layout. + +=item $e->WC_URL_NOT_EXIST + +The URL of the target working copy no longer exists at the HEAD revision. + +=back + +=back + +=head1 TO DO + +Reintegrate with L and L, +but separate this module into the CLI part and the CM part. Expose the remaining +CM functions when this is done. + +Use L to interface with Subversion. + +Move C out of this module. + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmBranch.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmBranch.pm new file mode 100644 index 0000000..a8908d9 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmBranch.pm @@ -0,0 +1,1217 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CmBranch +# +# DESCRIPTION +# This class contains methods for manipulating a branch. It is a sub-class of +# Fcm::CmUrl, and inherits all methods from that class. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CmBranch; +@ISA = qw(Fcm::CmUrl); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use Carp; +use File::Spec; + +# FCM component modules +use Fcm::CmCommitMessage; +use Fcm::CmUrl; +use Fcm::Config; +use Fcm::Interactive; +use Fcm::Keyword; +use Fcm::Util qw/run_command e_report w_report svn_date/; + +my @properties = ( + 'CREATE_REV', # revision at which the branch is created + 'DELETE_REV', # revision at which the branch is deleted + 'PARENT', # reference to parent branch Fcm::CmBranch + 'ANCESTOR', # list of common ancestors with other branches + # key = URL, value = ancestor Fcm::CmBranch + 'LAST_MERGE', # list of last merges from branches + # key = URL@REV, value = [TARGET, UPPER, LOWER] + 'AVAIL_MERGE', # list of available revisions for merging + # key = URL@REV, value = [REV ...] + 'CHILDREN', # list of children of this branch + 'SIBLINGS', # list of siblings of this branch +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch = Fcm::CmBranch->new (URL => $url,); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CmBranch class. +# +# ARGUMENTS +# URL - URL of a branch +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::CmUrl->new (%args); + + $self->{$_} = undef for (@properties); + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_branch->url_peg; +# $cm_branch->url_peg ($url); +# +# DESCRIPTION +# This method returns/sets the current URL. +# ------------------------------------------------------------------------------ + +sub url_peg { + my $self = shift; + + if (@_) { + if (! $self->{URL} or $_[0] ne $self->{URL}) { + # Re-set URL and other essential variables in the SUPER-class + $self->SUPER::url_peg (@_); + + # Re-set essential variables + $self->{$_} = undef for (@properties); + } + } + + return $self->{URL}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $cm_branch->create_rev; +# +# DESCRIPTION +# This method returns the revision at which the branch was created. +# ------------------------------------------------------------------------------ + +sub create_rev { + my $self = shift; + + if (not $self->{CREATE_REV}) { + return unless $self->url_exists ($self->pegrev); + + # Use "svn log" to find out the first revision of the branch + my %log = $self->svnlog (STOP_ON_COPY => 1); + + # Look at log in ascending order + my $rev = (sort {$a <=> $b} keys %log) [0]; + my $paths = $log{$rev}{paths}; + + # Get revision when URL is first added to the repository + if (exists $paths->{$self->branch_path}) { + $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A'; + } + } + + return $self->{CREATE_REV}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $parent = $cm_branch->parent; +# +# DESCRIPTION +# This method returns the parent (a Fcm::CmBranch object) of the current +# branch. +# ------------------------------------------------------------------------------ + +sub parent { + my $self = shift; + + if (not $self->{PARENT}) { + # Use the log to find out the parent revision + my %log = $self->svnlog (REV => $self->create_rev); + + if (exists $log{paths}{$self->branch_path}) { + my $path = $log{paths}{$self->branch_path}; + + if ($path->{action} eq 'A') { + if (exists $path->{'copyfrom-path'}) { + # Current branch is copied from somewhere, set the source as the parent + my $url = $self->root . $path->{'copyfrom-path'}; + my $rev = $path->{'copyfrom-rev'}; + $self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev); + + } else { + # Current branch is not copied from somewhere + $self->{PARENT} = $self; + } + } + } + } + + return $self->{PARENT}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $cm_branch->delete_rev; +# +# DESCRIPTION +# This method returns the revision at which the branch was deleted. +# ------------------------------------------------------------------------------ + +sub delete_rev { + my $self = shift; + + if (not $self->{DELETE_REV}) { + return if $self->url_exists ('HEAD'); + + # Container of the current URL + (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##; + + # Use "svn log" on the container between a revision where the branch exists + # and the HEAD + my $dir = Fcm::CmUrl->new (URL => $dir_url); + my %log = $dir->svnlog ( + REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)], + ); + + # Go through the log to see when branch no longer exists + for my $rev (sort {$a <=> $b} keys %log) { + next unless exists $log{$rev}{paths}{$self->branch_path} and + $log{$rev}{paths}{$self->branch_path}{action} eq 'D'; + + $self->{DELETE_REV} = $rev; + last; + } + } + + return $self->{DELETE_REV}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_branch->is_child_of ($branch); +# +# DESCRIPTION +# This method returns true if the current branch is a child of $branch. +# ------------------------------------------------------------------------------ + +sub is_child_of { + my ($self, $branch) = @_; + + # The trunk cannot be a child branch + return if $self->is_trunk; + + # If $branch is a branch, use name of $self to see when it is created + if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) { + my $rev = $1; + + # $self can only be a child if it is copied from a revision > the create + # revision of $branch + return if $rev < $branch->create_rev; + } + + return if $self->parent->url ne $branch->url; + + # If $branch is a branch, ensure that it is created before $self + return if $branch->is_branch and $self->create_rev <= $branch->create_rev; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_branch->is_sibling_of ($branch); +# +# DESCRIPTION +# This method returns true if the current branch is a sibling of $branch. +# ------------------------------------------------------------------------------ + +sub is_sibling_of { + my ($self, $branch) = @_; + + # The trunk cannot be a sibling branch + return if $branch->is_trunk; + + return if $self->parent->url ne $branch->parent->url; + + # If the parent is a branch, ensure they are actually the same branch + return if $branch->parent->is_branch and + $self->parent->create_rev != $branch->parent->create_rev; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $self->_get_relatives ($relation); +# +# DESCRIPTION +# This method sets the $self->{$relation} variable by inspecting the list of +# branches at the current revision of the current branch. $relation can be +# either "CHILDREN" or "SIBLINGS". +# ------------------------------------------------------------------------------ + +sub _get_relatives { + my ($self, $relation) = @_; + + my @branch_list = $self->branch_list; + + $self->{$relation} = []; + + # If we are searching for CHILDREN, get list of SIBLINGS, and vice versa + my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN'); + my %other_list; + if ($self->{$other}) { + %other_list = map {$_->url, 1} @{ $self->{$other} }; + } + + for my $u (@branch_list) { + # Ignore URL of current branch and its parent + next if $u eq $self->url; + next if $self->is_branch and $u eq $self->parent->url; + + # Ignore if URL is a branch detected to be another type of relative + next if exists $other_list{$u}; + + # Construct new Fcm::CmBranch object from branch URL + my $url = $u . ($self->pegrev ? '@' . $self->pegrev : ''); + my $branch = Fcm::CmBranch->new (URL => $url); + + # Test whether $branch is a relative we are looking for + if ($relation eq 'CHILDREN') { + push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self); + + } else { + push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self); + } + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @children = $cm_branch->children; +# +# DESCRIPTION +# This method returns a list of children (Fcm::CmBranch objects) of the +# current branch that exists in the current revision. +# ------------------------------------------------------------------------------ + +sub children { + my $self = shift; + + $self->_get_relatives ('CHILDREN') if not $self->{CHILDREN}; + + return @{ $self->{CHILDREN} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @siblings = $cm_branch->siblings; +# +# DESCRIPTION +# This method returns a list of siblings (Fcm::CmBranch objects) of the +# current branch that exists in the current revision. +# ------------------------------------------------------------------------------ + +sub siblings { + my $self = shift; + + $self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS}; + + return @{ $self->{SIBLINGS} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $ancestor = $cm_branch->ancestor ($branch); +# +# DESCRIPTION +# This method returns the common ancestor (a Fcm::CmBranch object) of a +# specified $branch and the current branch. The argument $branch must be a +# Fcm::CmBranch object. Both the current branch and $branch are assumed to be +# in the same project. +# ------------------------------------------------------------------------------ + +sub ancestor { + my ($self, $branch) = @_; + + if (not exists $self->{ANCESTOR}{$branch->url_peg}) { + if ($self->url_peg eq $branch->url_peg) { + $self->{ANCESTOR}{$branch->url_peg} = $self; + + } else { + # Get family tree of current branch, from trunk to current branch + my @this_family = ($self); + while (not $this_family [0]->is_trunk) { + unshift @this_family, $this_family [0]->parent; + } + + # Get family tree of $branch, from trunk to $branch + my @that_family = ($branch); + while (not $that_family [0]->is_trunk) { + unshift @that_family, $that_family [0]->parent; + } + + # Find common ancestor from list of parents + my $ancestor = undef; + + while (not $ancestor) { + # $this and $that should both start as some revisions on the trunk. + # Walk down a generation each time it loops around. + my $this = shift @this_family; + my $that = shift @that_family; + + if ($this->url eq $that->url) { + if ($this->is_trunk or $this->create_rev eq $that->create_rev) { + # $this and $that are the same branch + if (@this_family and @that_family) { + # More generations in both branches, try comparing the next + # generations. + next; + + } else { + # End of lineage in one of the branches, ancestor is at the lower + # revision of the current URL. + if ($this->pegrev and $that->pegrev) { + $ancestor = $this->pegrev < $that->pegrev ? $this : $that; + + } else { + $ancestor = $this->pegrev ? $this : $that; + } + } + + } else { + # Despite the same URL, $this and $that are different branches as + # they are created at different revisions. The ancestor must be the + # parent with the lower revision. (This should not occur at the + # start.) + $ancestor = $this->parent->pegrev < $that->parent->pegrev + ? $this->parent : $that->parent; + } + + } else { + # Different URLs, ancestor must be the parent with the lower revision. + # (This should not occur at the start.) + $ancestor = $this->parent->pegrev < $that->parent->pegrev + ? $this->parent : $that->parent; + } + } + + $self->{ANCESTOR}{$branch->url_peg} = $ancestor; + } + } + + return $self->{ANCESTOR}{$branch->url_peg}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($target, $upper, $lower) = $cm_branch->last_merge_from ( +# $branch, $stop_on_copy, +# ); +# +# DESCRIPTION +# This method returns a 3-element list with information of the last merge +# into the current branch from a specified $branch. The first element in the +# list $target (a Fcm::CmBranch object) is the target at which the merge was +# performed. (This can be the current branch or a parent branch up to the +# common ancestor with the specified $branch.) The second and third elements, +# $upper and $lower, (both Fcm::CmBranch objects), are the upper and lower +# ends of the source delta. If there is no merge from $branch into the +# current branch from their common ancestor to the current revision, this +# method will return an empty list. If $stop_on_copy is specified, it ignores +# merges from parents of $branch, and merges into parents of the current +# branch. +# ------------------------------------------------------------------------------ + +sub last_merge_from { + my ($self, $branch, $stop_on_copy) = @_; + + if (not exists $self->{LAST_MERGE}{$branch->url_peg}) { + # Get "log" of current branch down to the common ancestor + my %log = $self->svnlog ( + REV => [ + ($self->pegrev ? $self->pegrev : 'HEAD'), + $self->ancestor ($branch)->pegrev, + ], + + STOP_ON_COPY => $stop_on_copy, + ); + + my $cr = $self; + + # Go down the revision log, checking for merge template messages + REV: for my $rev (sort {$b <=> $a} keys %log) { + # Loop each line of the log message at each revision + my @msg = split /\n/, $log{$rev}{msg}; + + # Also consider merges into parents of current branch + $cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev); + + for (@msg) { + # Ignore unless log message matches a merge template + next unless /Merged into \S+: (\S+) cf\. (\S+)/; + + # Upper $1 and lower $2 ends of the source delta + my $u_path = $1; + my $l_path = $2; + + # Add the root directory to the paths if necessary + $u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/'; + $l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/'; + + # Only consider merges with specified branch (and its parent) + (my $path = $u_path) =~ s/@(\d+)$//; + my $u_rev = $1; + + my $br = $branch; + $br = $br->parent while ( + $br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy + ); + + next unless $br->branch_path eq $path; + + # If $br is a parent of branch, ignore those merges with the parent + # above the branch point of the current branch + next if $br->pegrev and $br->pegrev < $u_rev; + + # Set the return values + $self->{LAST_MERGE}{$branch->url_peg} = [ + Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target + Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper + Fcm::CmBranch->new (URL => $self->root . $l_path), # delta lower + ]; + + last REV; + } + } + } + + return (exists $self->{LAST_MERGE}{$branch->url_peg} + ? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ()); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]); +# +# DESCRIPTION +# This method returns a list of revisions of a specified $branch, which are +# available for merging into the current branch. If $stop_on_copy is +# specified, it will not list available merges from the parents of $branch. +# ------------------------------------------------------------------------------ + +sub avail_merge_from { + my ($self, $branch, $stop_on_copy) = @_; + + if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) { + # Find out the revision of the upper delta at the last merge from $branch + # If no merge is found, use revision of common ancestor with $branch + my @last_merge = $self->last_merge_from ($branch); + my $rev = $self->ancestor ($branch)->pegrev; + $rev = $last_merge [1]->pegrev + if @last_merge and $last_merge [1]->pegrev > $rev; + + # Get the "log" of the $branch down to $rev + my %log = $branch->svnlog ( + REV => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev], + STOP_ON_COPY => $stop_on_copy, + ); + + # No need to include $rev itself, as it has already been merged + delete $log{$rev}; + + # No need to include the branch create revision + delete $log{$branch->create_rev} + if $branch->is_branch and exists $log{$branch->create_rev}; + + if (keys %log) { + # Check whether there is a latest merge from $self into $branch, if so, + # all revisions of $branch below that merge should become unavailable + my @last_merge_into = $branch->last_merge_from ($self); + + if (@last_merge_into) { + for my $rev (keys %log) { + delete $log{$rev} if $rev < $last_merge_into [0]->pegrev; + } + } + } + + # Available merges include all revisions above the branch creation revision + # or the revision of the last merge + $self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log]; + } + + return @{ $self->{AVAIL_MERGE}{$branch->url_peg} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $lower = $cm_branch->base_of_merge_from ($branch); +# +# DESCRIPTION +# This method returns the lower delta (a Fcm::CmBranch object) for the next +# merge from $branch. +# ------------------------------------------------------------------------------ + +sub base_of_merge_from { + my ($self, $branch) = @_; + + # Base is the ancestor if there is no merge between $self and $branch + my $return = $self->ancestor ($branch); + + # Get configuration for the last merge from $branch to $self + my @merge_from = $self->last_merge_from ($branch); + + # Use the upper delta of the last merge from $branch, as all revisions below + # that have already been merged into the $self + $return = $merge_from [1] + if @merge_from and $merge_from [1]->pegrev > $return->pegrev; + + # Get configuration for the last merge from $self to $branch + my @merge_into = $branch->last_merge_from ($self); + + # Use the upper delta of the last merge from $self, as the current revision + # of $branch already contains changes of $self up to the peg revision of the + # upper delta + $return = $merge_into [1] + if @merge_into and $merge_into [0]->pegrev > $return->pegrev; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir); +# +# DESCRIPTION +# This method returns true if a merge from the sub-directory $subdir in +# $branch is allowed - i.e. it does not result in losing changes made in +# $branch outside of $subdir. +# ------------------------------------------------------------------------------ + +sub allow_subdir_merge_from { + my ($self, $branch, $subdir) = @_; + + # Get revision at last merge from $branch or ancestor + my @merge_from = $self->last_merge_from ($branch); + my $last = @merge_from ? $merge_from [1] : $self->ancestor ($branch); + my $rev = $last->pegrev; + + my $return = 1; + if ($branch->pegrev > $rev) { + # Use "svn diff --summarize" to work out what's changed between last + # merge/ancestor and current revision + my $range = $branch->pegrev . ':' . $rev; + my @out = &run_command ( + [qw/svn diff --summarize -r/, $range, $branch->url_peg], METHOD => 'qx', + ); + + # Returns false if there are changes outside of $subdir + my $url = join ('/', $branch->url, $subdir); + for my $line (@out) { + chomp $line; + $line = substr ($line, 7); # file name begins at column 7 + if ($line !~ m#^$url(?:/|$)#) { + $return = 0; + last; + } + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch->create ( +# SRC => $src, +# TYPE => $type, +# NAME => $name, +# [PASSWORD => $password,] +# [REV_FLAG => $rev_flag,] +# [TICKET => \@tickets,] +# [REV => $rev,] +# [NON_INTERACTIVE => 1,] +# [SVN_NON_INTERACTIVE => 1,] +# ); +# +# DESCRIPTION +# This method creates a branch in a Subversion repository. +# +# OPTIONS +# SRC - reference to a Fcm::CmUrl object. +# TYPE - Specify the branch type. See help in "fcm branch" for +# further information. +# NAME - specify the name of the branch. +# NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE +# to true automatically. +# PASSWORD - specify the password for commit access. +# REV - specify the operative revision of the source. +# REV_FLAG - A flag to specify the behaviour of the prefix to the +# branch name. See help in "fcm branch" for further +# information. +# SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit, +# etc. This option is implied by NON_INTERACTIVE. +# TICKET - Specify one or more related tickets for the branch. +# ------------------------------------------------------------------------------ + +sub create { + my $self = shift; + my %args = @_; + + # Options + # ---------------------------------------------------------------------------- + # Compulsory options + my $src = $args{SRC}; + my $type = $args{TYPE}; + my $name = $args{NAME}; + + # Other options + my $rev_flag = $args{REV_FLAG} ? $args{REV_FLAG} : 'NORMAL'; + my @tickets = exists $args{TICKET} ? @{ $args{TICKET} } : (); + my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef; + my $orev = exists $args{REV} ? $args{REV} : 'HEAD'; + + my $non_interactive = exists $args{NON_INTERACTIVE} + ? $args{NON_INTERACTIVE} : 0; + my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE} + ? $args{SVN_NON_INTERACTIVE} : 0; + $svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive; + + # Analyse the source URL + # ---------------------------------------------------------------------------- + # Create branch from the trunk by default + $src->branch ('trunk') if not $src->branch; + + # Remove "sub-directory" part from source URL + $src->subdir ('') if $src->subdir; + + # Remove "peg revision" part because it does not work with "svn copy" + $src->pegrev ('') if $src->pegrev; + + # Find out the URL and the last changed revision of the specified URL at the + # specified operative revision + my $url = $src->svninfo (FLAG => 'URL', REV => $orev); + e_report $src->url, ': cannot determine the operative URL at revision ', + $orev, ', abort.' if not $url; + + $src->url ($url) if $url ne $src->url; + + my $rev = $src->svninfo (FLAG => 'Last Changed Rev', REV => $orev); + e_report $src->url, ': cannot determine the last changed rev at revision', + $orev, ', abort.' if not $rev; + + # Warn user if last changed revision is not the specified revision + w_report 'Warning: branch will be created from revision ', $rev, + ', i.e. the last changed rev.' + unless $orev and $orev eq $rev; + + # Determine the sub-directory names of the branch + # ---------------------------------------------------------------------------- + my @branch_dirs = ('branches'); + + # Split branch type flags into a hash table + my %type_flags = (); + $type_flags{$_} = 1 for ((split /$Fcm::Config::DELIMITER/, $type)); + + # Branch sub-directory 1, development, test or package + for my $flag (qw/DEV TEST PKG/) { + if (exists $type_flags{$flag}) { + push @branch_dirs, lc ($flag); + last; + } + } + + # Branch sub-directory 2, user, share, configuration or release + if (exists $type_flags{USER}) { + die 'Unable to determine your user ID, abort' unless $self->config->user_id; + + push @branch_dirs, $self->config->user_id; + + } else { + for my $flag (keys %Fcm::CmUrl::owner_keywords) { + if (exists $type_flags{uc ($flag)}) { + push @branch_dirs, $flag; + last; + } + } + } + + # Branch sub-directory 3, branch name + # Prefix branch name with revision number/keyword if necessary + my $prefix = ''; + if ($rev_flag ne 'NONE') { + $prefix = $rev; + + # Attempt to replace revision number with a revision keyword if necessary + if ($rev_flag eq 'NORMAL') { + $prefix = (Fcm::Keyword::unexpand($src->url_peg(), $rev))[1]; + } + + # $prefix is still a revision number, add "r" in front of it + $prefix = 'r' . $prefix if $prefix eq $rev; + + # Add an underscore before the branch name + $prefix.= '_'; + } + + # Branch name + push @branch_dirs, $prefix . $name; + + # Check whether the branch already exists, fail if so + # ---------------------------------------------------------------------------- + # Construct the URL of the branch + $self->project_url ($src->project_url); + $self->branch (join ('/', @branch_dirs)); + + # Check that branch does not already exists + e_report $self->url, ': branch already exists, abort.' if $self->url_exists; + + # Message for the commit log + # ---------------------------------------------------------------------------- + my @message = ('Created ' . $self->branch_path . ' from ' . + $src->branch_path . '@' . $rev . '.' . "\n"); + + # Add related Trac ticket links to commit log if set + if (@tickets) { + my $ticket_mesg = 'Relates to ticket' . (@tickets > 1 ? 's' : ''); + + while (my $ticket = shift @tickets) { + $ticket_mesg .= ' #' . $ticket; + $ticket_mesg .= (@tickets > 1 ? ',' : ' and') if @tickets >= 1; + } + + push @message, $ticket_mesg . ".\n"; + } + + # Create a temporary file for the commit log message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->auto_mesg (\@message); + $ci_mesg->ignore_mesg (['A' . ' ' x 4 . $self->url . "\n"]); + my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive); + + # Check with the user to see if he/she wants to go ahead + # ---------------------------------------------------------------------------- + if (not $non_interactive) { + my $reply = Fcm::Interactive::get_input( + title => 'fcm branch', + message => 'Would you like to go ahead and create this branch?', + type => 'yn', + default => 'n', + ); + + return unless $reply eq 'y'; + } + + # Ensure existence of container sub-directories of the branch + # ---------------------------------------------------------------------------- + for my $i (0 .. $#branch_dirs - 1) { + my $subdir = join ('/', @branch_dirs[0 .. $i]); + my $subdir_url = Fcm::CmUrl->new (URL => $src->project_url . '/' . $subdir); + + # Check whether each sub-directory of the branch already exists, + # if sub-directory does not exist, create it + next if $subdir_url->url_exists; + + print 'Creating sub-directory: ', $subdir, "\n"; + + my @command = ( + qw/svn mkdir/, + '-m', 'Created ' . $subdir . ' directory.', + ($svn_non_interactive ? '--non-interactive' : ()), + (defined $password ? ('--password', $password) : ()), + + $subdir_url->url, + ); + &run_command (\@command); + } + + # Create the branch + # ---------------------------------------------------------------------------- + { + print 'Creating branch ', $self->url, ' ...', "\n"; + my @command = ( + qw/svn copy/, + '-r', $rev, + '-F', $logfile, + ($svn_non_interactive ? '--non-interactive' : ()), + (defined $password ? ('--password', $password) : ()), + + $src->url, $self->url, + ); + &run_command (\@command); + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch->delete ( +# [NON_INTERACTIVE => 1,] +# [PASSWORD => $password,] +# [SVN_NON_INTERACTIVE => 1,] +# ); +# +# DESCRIPTION +# This method deletes the current branch from the Subversion repository. +# +# OPTIONS +# NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE +# to true automatically. +# PASSWORD - specify the password for commit access. +# SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit, +# etc. This option is implied by NON_INTERACTIVE. +# ------------------------------------------------------------------------------ + +sub del { + my $self = shift; + my %args = @_; + + # Options + # ---------------------------------------------------------------------------- + my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef; + my $non_interactive = exists $args{NON_INTERACTIVE} + ? $args{NON_INTERACTIVE} : 0; + my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE} + ? $args{SVN_NON_INTERACTIVE} : 0; + $svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive; + + # Ensure URL is a branch + # ---------------------------------------------------------------------------- + e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch; + + # Message for the commit log + # ---------------------------------------------------------------------------- + my @message = ('Deleted ' . $self->branch_path . '.' . "\n"); + + # Create a temporary file for the commit log message + my $ci_mesg = Fcm::CmCommitMessage->new; + $ci_mesg->auto_mesg (\@message); + $ci_mesg->ignore_mesg (['D' . ' ' x 4 . $self->url . "\n"]); + my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive); + + # Check with the user to see if he/she wants to go ahead + # ---------------------------------------------------------------------------- + if (not $non_interactive) { + my $mesg = ''; + my $user = $self->config->user_id; + + if ($user and $self->branch_owner ne $user) { + $mesg .= "\n"; + + if (exists $Fcm::CmUrl::owner_keywords{$self->branch_owner}) { + my $type = $Fcm::CmUrl::owner_keywords{$self->branch_owner}; + $mesg .= '*** WARNING: YOU ARE DELETING A ' . uc ($type) . + ' BRANCH.'; + + } else { + $mesg .= '*** WARNING: YOU ARE DELETING A BRANCH NOT OWNED BY YOU.'; + } + + $mesg .= "\n" . + '*** Please ensure that you have the owner\'s permission.' . + "\n\n"; + } + + $mesg .= 'Would you like to go ahead and delete this branch?'; + + my $reply = Fcm::Interactive::get_input ( + title => 'fcm branch', + message => $mesg, + type => 'yn', + default => 'n', + ); + + return unless $reply eq 'y'; + } + + # Delete branch if answer is "y" for "yes" + # ---------------------------------------------------------------------------- + print 'Deleting branch ', $self->url, ' ...', "\n"; + my @command = ( + qw/svn delete/, + '-F', $logfile, + (defined $password ? ('--password', $password) : ()), + ($svn_non_interactive ? '--non-interactive' : ()), + + $self->url, + ); + &run_command (\@command); + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_branch->display_info ( +# [SHOW_CHILDREN => 1], +# [SHOW_OTHER => 1] +# [SHOW_SIBLINGS => 1] +# ); +# +# DESCRIPTION +# This method displays information of the current branch. If SHOW_CHILDREN is +# set, it shows information of all current children branches of the current +# branch. If SHOW_SIBLINGS is set, it shows information of siblings that have +# been merged recently with the current branch. If SHOW_OTHER is set, it shows +# information of custom/reverse merges. +# ------------------------------------------------------------------------------ + +sub display_info { + my $self = shift; + my %args = @_; + + # Arguments + # ---------------------------------------------------------------------------- + my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0; + my $show_other = exists $args{SHOW_OTHER } ? $args{SHOW_OTHER} : 0; + my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0; + + # Useful variables + # ---------------------------------------------------------------------------- + my $separator = '-' x 80 . "\n"; + my $separator2 = ' ' . '-' x 78 . "\n"; + + # Print "info" as returned by "svn info" + # ---------------------------------------------------------------------------- + for my $key ('URL', 'Repository Root', 'Revision', 'Last Changed Author', + 'Last Changed Rev', 'Last Changed Date') { + print $key, ': ', $self->svninfo (FLAG => $key), "\n" + if $self->svninfo (FLAG => $key); + } + + if ($self->config->verbose) { + # Verbose mode, print log message at last changed revision + my %log = $self->svnlog (REV => $self->svninfo (FLAG => 'Last Changed Rev')); + my @log = split /\n/, $log{msg}; + print 'Last Changed Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n"; + } + + if ($self->is_branch) { + # Print create information + # -------------------------------------------------------------------------- + my %log = $self->svnlog (REV => $self->create_rev); + + print $separator; + print 'Branch Create Author: ', $log{author}, "\n" if $log{author}; + print 'Branch Create Rev: ', $self->create_rev, "\n"; + print 'Branch Create Date: ', &svn_date ($log{date}), "\n"; + + if ($self->config->verbose) { + # Verbose mode, print log message at last create revision + my @log = split /\n/, $log{msg}; + print 'Branch Create Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n"; + } + + # Print delete information if branch no longer exists + # -------------------------------------------------------------------------- + print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev; + + # Report merges into/from the parent + # -------------------------------------------------------------------------- + # Print the URL@REV of the parent branch + print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n"; + + # Set up a new object for the parent at the current revision + # -------------------------------------------------------------------------- + my $p_url = $self->parent->url; + $p_url .= '@' . $self->pegrev if $self->pegrev; + my $parent = Fcm::CmBranch->new (URL => $p_url); + + if (not $parent->url_exists) { + print 'Branch parent deleted.', "\n"; + return; + } + + # Report merges into/from the parent + # -------------------------------------------------------------------------- + print $self->_report_merges ($parent, 'Parent'); + } + + # Report merges with siblings + # ---------------------------------------------------------------------------- + if ($show_siblings) { + # Report number of sibling branches found + print $separator, 'Searching for siblings ... '; + my @siblings = $self->siblings; + print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'), + ' found.', "\n"; + + # Report branch name and merge information only if there are recent merges + my $out = ''; + for my $sibling (@siblings) { + my $string = $self->_report_merges ($sibling, 'Sibling'); + + $out .= $separator2 . ' ' . $sibling->url . "\n" . $string if $string; + } + + if (@siblings) { + if ($out) { + print 'Merges with existing siblings:', "\n", $out; + + } else { + print 'No merges with existing siblings.', "\n"; + } + } + } + + # Report children + # ---------------------------------------------------------------------------- + if ($show_children) { + # Report number of child branches found + print $separator, 'Searching for children ... '; + my @children = $self->children; + print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'), + ' found.', "\n"; + + # Report children if they exist + print 'Current children:', "\n" if @children; + + for my $child (@children) { + print $separator2, ' ', $child->url, "\n"; + print ' Child Create Rev: ', $child->create_rev, "\n"; + print $self->_report_merges ($child, 'Child'); + } + } + + # Report custom/reverse merges into the branch + # ---------------------------------------------------------------------------- + if ($show_other) { + my %log = $self->svnlog (STOP_ON_COPY => 1); + my @out; + + # Go down the revision log, checking for merge template messages + REV: for my $rev (sort {$b <=> $a} keys %log) { + # Loop each line of the log message at each revision + my @msg = split /\n/, $log{$rev}{msg}; + + for (@msg) { + # Ignore unless log message matches a merge template + if (/^Reversed r\d+(:\d+)? of \S+$/ or + s/^(Custom merge) into \S+(:.+)$/$1$2/) { + push @out, ('r' . $rev . ': ' . $_) . "\n"; + } + } + } + + print $separator, 'Other merges:', "\n", @out if @out; + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $self->_report_merges ($branch, $relation); +# +# DESCRIPTION +# This method returns a string for displaying merge information with a +# branch, the $relation of which can be a Parent, a Sibling or a Child. +# ------------------------------------------------------------------------------ + +sub _report_merges { + my ($self, $branch, $relation) = @_; + + my $indent = ($relation eq 'Parent') ? '' : ' '; + my $separator = ($relation eq 'Parent') ? ('-' x 80) : (' ' . '-' x 78); + $separator .= "\n"; + + my $return = ''; + + # Report last merges into/from the $branch + # ---------------------------------------------------------------------------- + my %merge = ( + 'Last Merge From ' . $relation . ':' + => [$self->last_merge_from ($branch, 1)], + 'Last Merge Into ' . $relation . ':' + => [$branch->last_merge_from ($self, 1)], + ); + + if ($self->config->verbose) { + # Verbose mode, print the log of the merge + for my $key (keys %merge) { + next if not @{ $merge{$key} }; + + # From: target (0) is self, upper delta (1) is $branch + # Into: target (0) is $branch, upper delta (1) is self + my $t = ($key =~ /From/) ? $self : $branch; + + $return .= $indent . $key . "\n"; + $return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev); + } + + } else { + # Normal mode, print in simplified form (rREV Parent@REV) + for my $key (keys %merge) { + next if not @{ $merge{$key} }; + + # From: target (0) is self, upper delta (1) is $branch + # Into: target (0) is $branch, upper delta (1) is self + $return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' . + $merge{$key}[1]->path_peg . ' cf. ' . + $merge{$key}[2]->path_peg . "\n"; + } + } + + if ($relation eq 'Sibling') { + # For sibling, do not report further if there is no recent merge + my @values = values %merge; + + return $return unless (@{ $values[0] } or @{ $values[1] }); + } + + # Report available merges into/from the $branch + # ---------------------------------------------------------------------------- + my %avail = ( + 'Merges Avail From ' . $relation . ':' + => ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]), + 'Merges Avail Into ' . $relation . ':' + => [$branch->avail_merge_from ($self, 1)], + ); + + if ($self->config->verbose) { + # Verbose mode, print the log of each revision + for my $key (keys %avail) { + next unless @{ $avail{$key} }; + + $return .= $indent . $key . "\n"; + + my $s = ($key =~ /From/) ? $branch: $self; + + for my $rev (@{ $avail{$key} }) { + $return .= $separator . $s->display_svnlog ($rev); + } + } + + } else { + # Normal mode, print only the revisions + for my $key (keys %avail) { + next unless @{ $avail{$key} }; + + $return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n"; + } + } + + return $return; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmCommitMessage.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmCommitMessage.pm new file mode 100644 index 0000000..e0407ab --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmCommitMessage.pm @@ -0,0 +1,319 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CmCommitMessage +# +# DESCRIPTION +# This class contains methods to read, write and edit the commit message file +# in a working copy. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CmCommitMessage; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use Carp; +use Cwd; +use File::Spec; +use File::Temp qw/tempfile/; + +# FCM component modules +use Fcm::Base; +use Fcm::Util qw/e_report run_command/; + +# List of property methods for this class +my @scalar_properties = ( + 'auto_mesg', # the automatically inserted part of a commit message + 'base', # the base name of the commit message file + 'dir', # the directory container of the commit message file + 'ignore_mesg', # the ignored part of a commit message + 'user_mesg', # the user defined part of a commit message +); + +# Commit log delimiter messages +my $log_delimiter = '--Add your commit message ABOVE - ' . + 'do not alter this line or those below--'; +my $auto_delimiter = '--FCM message (will be inserted automatically)--'; +my $auto_delimiter_old = '--This line will be ignored and those below ' . + 'will be inserted automatically--'; +my $status_delimiter = '--Change summary ' . + '(not part of commit message)--'; +my $status_delimiter_old = '--This line, and those below, will be ignored--'; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::CmCommitMessage->new (); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CmCommitMessage class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'base') { + # Reference to an array + $self->{$name} = '#commit_message#'; + + } elsif ($name eq 'dir') { + # Current working directory + $self->{$name} = &cwd (); + + } elsif ($name =~ /_mesg$/) { + # Reference to an array + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $file = $obj->file; +# $obj->file ($file); +# +# DESCRIPTION +# This method returns the full name of the commit message file. If an +# argument is specified, the file is reset using the value of the argument. +# ------------------------------------------------------------------------------ + +sub file { + my ($self, $file) = @_; + + if ($file) { + $self->dir (dirname ($file)); + $self->base (basename ($file)); + } + + return File::Spec->catfile ($self->dir, $self->base); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($user, $auto) = $obj->read_file (); +# +# DESCRIPTION +# This function reads from the commit log message file. It resets the user +# and the automatic messages after reading the file. It returns the message +# back in two array references. +# ------------------------------------------------------------------------------ + +sub read_file { + my $self = shift; + + my @user = (); + my @auto = (); + my $file = $self->file; + + if (-r $file) { + open FILE, '<', $file or croak 'Cannot open ', $file, '(', $!, '), abort'; + + my $in_auto = 0; + while () { + + next if (index ($_, $log_delimiter) == 0); + + if (index ($_, $status_delimiter) == 0 || + index ($_, $status_delimiter_old) == 0) { + # Ignore after the ignore delimiter + last; + } + + if (index ($_, $auto_delimiter) == 0 || + index ($_, $auto_delimiter_old) == 0) { + # Beginning of the automatically inserted message + $in_auto = 1; + next; + } + + if ($in_auto) { + push @auto, $_; + + } else { + push @user, $_; + } + } + + close FILE; + + $self->user_mesg (\@user); + $self->auto_mesg (\@auto); + } + + return (\@user, \@auto); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj->write_file (); +# +# DESCRIPTION +# This function writes to the commit log message file based on the content of +# the user defined message, and the automatically inserted message. +# ------------------------------------------------------------------------------ + +sub write_file { + my $self = shift; + my %args = @_; + + my @user = @{ $self->user_mesg }; + my @auto = @{ $self->auto_mesg }; + my $file = $self->file; + + open FILE, '>', $file or die 'Cannot open ', $file, '(', $!, '), abort'; + print FILE @user; + print FILE $log_delimiter, "\n", $auto_delimiter, "\n", @auto if @auto; + close FILE or croak 'Cannot close ', $file, '(', $!, '), abort'; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $file = $obj->edit_file ([TEMP => 1,] [BATCH => 1,]); +# +# DESCRIPTION +# This function normally triggers an editor for editing the commit message. +# If TEMP is set, it edits a temporary file. Otherwise, it edits the current +# commit message file. It resets the user defined message on success. Returns +# the name of the commit log file. Do not start the editor if BATCH is set. +# ------------------------------------------------------------------------------ + +sub edit_file { + my $self = shift; + my %args = @_; + my $temp = exists $args{TEMP} ? $args{TEMP} : 0; + my $batch = exists $args{BATCH} ? $args{BATCH} : 0; + + my @user = @{ $self->user_mesg }; + my @auto = @{ $self->auto_mesg }; + my @ignore = @{ $self->ignore_mesg }; + my $file = $self->file; + + if ($temp) { + my $fh; + ($fh, $file) = tempfile (SUFFIX => ".fcm", UNLINK => 1); + close $fh; + } + + # Add original or code driven message and status information to the file + my $select = select; + open FILE, '>', $file or croak 'Cannot open ', $file, ' (', $!, '), abort'; + select FILE; + + print @user; + print (@auto || @user ? '' : "\n"); + print $log_delimiter, "\n"; + print $auto_delimiter, "\n", @auto, "\n" if @auto; + print $status_delimiter, "\n\n"; + print @ignore if @ignore; + + close FILE or die 'Cannot close ', $file, ' (', $!, '), abort'; + select $select; + + if (not $batch) { + # Select editor + my $editor = 'nedit'; + + if ($ENV{'SVN_EDITOR'}) { + $editor = $ENV{'SVN_EDITOR'}; + + } elsif ($ENV{'VISUAL'}) { + $editor = $ENV{'VISUAL'}; + + } elsif ($ENV{'EDITOR'}) { + $editor = $ENV{'EDITOR'}; + } + + # Execute command to start the editor + print 'Starting ', $editor, ' to edit commit message ...', "\n"; + &run_command ([split (/\s+/, $editor), $file]); + } + + # Read the edited file, and extract user log message from it + open FILE, '<', $file or croak 'Cannot open ', $file, ' (', $!, '), abort'; + my (@log); + my $delimiter_found = 0; + + while () { + if (index ($_, $log_delimiter) == 0) { + $delimiter_found = 1; + last; + } + push @log, $_; + } + + close FILE; + + # Ensure log delimiter line was not altered + e_report 'Error: the line "', $log_delimiter, '" has been altered, abort.' + if not $delimiter_found; + + # Check for empty commit log + e_report 'Error: log message unchanged or not specified, abort.' + if join (' ', (@log, @auto)) =~ /^\s*$/; + + # Echo the commit message to standard output + my $separator = '-' x 80 . "\n"; + print 'Change summary:', "\n"; + print $separator, @ignore, $separator; + print 'Commit message is as follows:', "\n"; + print $separator, @log, @auto, $separator; + + open FILE, '>', $file or croak 'Cannot open ', $file, ' (', $!, '), abort'; + print FILE @log, @auto; + close FILE or croak 'Cannot close ', $file, ' (', $!, '), abort'; + + # Reset the array for the user specified log message + $self->user_mesg (\@log); + + return $file; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmUrl.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmUrl.pm new file mode 100644 index 0000000..810aadd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/CmUrl.pm @@ -0,0 +1,1149 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::CmUrl +# +# DESCRIPTION +# This class contains methods for manipulating a Subversion URL in a standard +# FCM project. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::CmUrl; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use HTTP::Date; +use XML::DOM; + +# FCM component modules +use Fcm::Base; +use Fcm::Keyword; +use Fcm::Util qw/run_command svn_date/; + +# Special branches +our %owner_keywords = (Share => 'shared', Config => 'config', Rel => 'release'); + +# Revision pattern +my $rev_pattern = '\d+|HEAD|BASE|COMMITTED|PREV|\{.+\}'; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $cm_url = Fcm::CmUrl->new ([URL => $url,]); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::CmUrl class. +# +# ARGUMENTS +# URL - URL of a branch +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + $self->{URL} = (exists $args{URL} ? $args{URL} : ''); + + for (qw/ANALYSED BRANCH BRANCH_LIST INFO LIST LOG LOG_RANGE PEGREV RLIST + PROJECT SUBDIR/) { + $self->{$_} = undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->url_peg; +# $cm_url->url_peg ($url); +# +# DESCRIPTION +# This method returns/sets the current URL@PEG. +# ------------------------------------------------------------------------------ + +sub url_peg { + my $self = shift; + + if (@_) { + if (! $self->{URL} or $_[0] ne $self->{URL}) { + # Re-set URL + $self->{URL} = shift; + + # Re-set essential variables + $self->{$_} = undef for (qw/ANALYSED RLIST LIST INFO LOG LOG_RANGE/); + } + } + + return $self->{URL}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_url (); +# +# DESCRIPTION +# Returns true if current url is a valid Subversion URL. +# ------------------------------------------------------------------------------ + +sub is_url { + my $self = shift; + + # This should handle URL beginning with svn://, http:// and svn+ssh:// + return ($self->url_peg =~ m#^[\+\w]+://#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->url_exists ([$rev]); +# +# DESCRIPTION +# Returns true if current url exists (at operative revision $rev) in a +# Subversion repository. +# ------------------------------------------------------------------------------ + +sub url_exists { + my ($self, $rev) = @_; + + my $exists = $self->svnlist (REV => $rev); + + return defined ($exists); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $cm_url->svninfo ([FLAG => $flag], [REV => $rev]); +# +# DESCRIPTION +# Returns the value of $flag, where $flag is a field returned by "svn info". +# (If $flag is not set, default to "URL".) Otherwise returns an empty string. +# If REV is specified, it will be used as the operative revision. +# ------------------------------------------------------------------------------ + +sub svninfo { + my $self = shift; + my %args = @_; + + my $flag = exists $args{FLAG} ? $args{FLAG} : 'URL'; + my $rev = exists $args{REV} ? $args{REV} : undef; + + $rev = ($self->pegrev ? $self->pegrev : 'HEAD') if not $rev; + + return if not $self->is_url; + + # Get "info" for the specified revision if necessary + if (not exists $self->{INFO}{$rev}) { + # Invoke "svn info" command + my @info = &run_command ( + [qw/svn info -r/, $rev, $self->url_peg], + PRINT => $self->config->verbose > 2, + METHOD => 'qx', + DEVNULL => 1, + ERROR => 'ignore', + ); + + # Store selected information + for (@info) { + chomp; + + if (/^(.+?):\s*(.+)$/) { + $self->{INFO}{$rev}{$1} = $2; + } + } + } + + my $return = exists $self->{INFO}{$rev}{$flag} + ? $self->{INFO}{$rev}{$flag} : undef; + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %logs = $cm_url->svnlog ( +# [REV => $rev,] +# [REV => \@revs,] # reference to a 2-element array +# [STOP_ON_COPY => 1,] +# ); +# +# DESCRIPTION +# Returns the logs for the current URL. If REV is a range of revisions or not +# specified, return a hash where the keys are revision numbers and the values +# are the entries (which are hash references). If a single REV is specified, +# return the entry (a hash reference) at the specified REV. Each entry in the +# returned list is a hash reference, with the following structure: +# +# $entry = { +# author => $author, # the commit author +# date => $date, # the commit date (in seconds since epoch) +# msg => $msg, # the log message +# paths => { # list of changed paths +# $path1 => { # a changed path +# copyfrom-path => $frompath, # copy-from-path +# copyfrom-rev => $fromrev, # copy-from-revision +# action => $action, # action status code +# }, +# ... => { ... }, # ... more changed paths ... +# }, +# } +# ------------------------------------------------------------------------------ + +sub svnlog { + my $self = shift; + my %args = @_; + + my $stop_on_copy = exists $args{STOP_ON_COPY} ? $args{STOP_ON_COPY} : 0; + my $rev_arg = exists $args{REV} ? $args{REV} : 0; + + my @revs; + + # Get revision options + # ---------------------------------------------------------------------------- + if ($rev_arg) { + if (ref ($rev_arg)) { + # Revsion option is an array, a range of revisions specified? + ($revs [0], $revs [1]) = @$rev_arg; + + } else { + # A single revision specified + $revs [0] = $rev_arg; + } + + # Expand 'HEAD' revision + for my $rev (@revs) { + next unless uc ($rev) eq 'HEAD'; + $rev = $self->svninfo (FLAG => 'Revision', REV => 'HEAD'); + } + + } else { + # No revision option specified, get log for all revisions + $revs [0] = $self->svninfo (FLAG => 'Revision'); + $revs [1] = 1; + } + + $revs [1] = $revs [0] if not $revs [1]; + @revs = sort {$b <=> $a} @revs; + + # Check whether a "svn log" run is necessary + # ---------------------------------------------------------------------------- + my $need_update = ! ($revs [0] == $revs [1] and exists $self->{LOG}{$revs [0]}); + my @ranges = @revs; + if ($need_update and $self->{LOG_RANGE}) { + my %log_range = %{ $self->{LOG_RANGE} }; + + if ($stop_on_copy) { + $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER_SOC}; + + } else { + $ranges [1] = $log_range{UPPER} if $ranges [1] >= $log_range{LOWER}; + } + } + + $need_update = 0 if $ranges [0] < $ranges [1]; + + if ($need_update) { + # Invoke "svn log" command for all revisions of the current branch + # -------------------------------------------------------------------------- + my @command = ( + qw/svn log --xml -v/, ($stop_on_copy ? '--stop-on-copy' : ()), + '-r' . join (':', @ranges), + $self->url_peg, + ); + + my $rc; + my @xml = &run_command ( + \@command, + PRINT => $self->config->verbose > 2, + METHOD => 'qx', + DEVNULL => 1, + ERROR => 'ignore', + RC => \$rc, + ); + + # Parse the XML + # -------------------------------------------------------------------------- + if (not $rc) { + my $parser = XML::DOM::Parser->new; + my $doc = $parser->parse (join ('', @xml)); + + my $entry_list = $doc->getElementsByTagName ('logentry'); + + # Record the author, date, message and path change for each revision + for my $i (0 .. $entry_list->getLength - 1) { + # Select current entry from node list + my $entry = $entry_list->item ($i); + my %this = (); + + # Revision is an attribute of the entry node + my $rev = $entry->getAttributeNode ('revision')->getValue; + + # Author, date and log message are children elements of the entry node + for my $key (qw/author date msg/) { + # Get data of each node, also convert date to seconds since epoch + my $node = $entry->getElementsByTagName ($key)->item (0); + my $data = ($node and $node->getFirstChild) + ? $node->getFirstChild->getData : ''; + $this{$key} = ($key eq 'date' ? str2time ($data) : $data); + } + + # Path nodes are grand children elements of the entry node + my $paths = $entry->getElementsByTagName ('path'); + + for my $p (0 .. $paths->getLength - 1) { + # Select current path node from node list + my $node = $paths->item ($p); + + # Get data from the path node + my $path = $node->getFirstChild->getData; + $this{paths}{$path} = {}; + + # Action, copyfrom-path and copyfrom-rev are attributes of path nodes + for my $key (qw/action copyfrom-path copyfrom-rev/) { + next unless $node->getAttributeNode ($key); # ensure attribute exists + + $this{paths}{$path}{$key} = $node->getAttributeNode ($key)->getValue; + } + } + + $self->{LOG}{$rev} = \%this; + } + } + + # Update the range cache + # -------------------------------------------------------------------------- + # Upper end of the range + $self->{LOG_RANGE}{UPPER} = $ranges [0] + if ! $self->{LOG_RANGE}{UPPER} or $ranges [0] > $self->{LOG_RANGE}{UPPER}; + + # Lower end of the range, need to take into account the stop-on-copy option + if ($stop_on_copy) { + # Lower end of the range with stop-on-copy option + $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1] + if ! $self->{LOG_RANGE}{LOWER_SOC} or + $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC}; + + my $low = (sort {$a <=> $b} keys %{ $self->{LOG} }) [0]; + $self->{LOG_RANGE}{LOWER} = $low + if ! $self->{LOG_RANGE}{LOWER} or $low < $self->{LOG_RANGE}{LOWER}; + + } else { + # Lower end of the range without the stop-on-copy option + $self->{LOG_RANGE}{LOWER} = $ranges [1] + if ! $self->{LOG_RANGE}{LOWER} or + $ranges [1] < $self->{LOG_RANGE}{LOWER}; + + $self->{LOG_RANGE}{LOWER_SOC} = $ranges [1] + if ! $self->{LOG_RANGE}{LOWER_SOC} or + $ranges [1] < $self->{LOG_RANGE}{LOWER_SOC}; + } + } + + my %return = (); + + if (! $rev_arg or ref ($rev_arg)) { + # REV is an array, return log entries if they are within range + for my $rev (sort {$b <=> $a} keys %{ $self->{LOG} }) { + next if $rev > $revs [0] or $revs [1] > $rev; + + $return{$rev} = $self->{LOG}{$rev}; + + if ($stop_on_copy) { + last if exists $self->{LOG}{$rev}{paths}{$self->branch_path} and + $self->{LOG}{$rev}{paths}{$self->branch_path}{action} eq 'A'; + } + } + + } else { + # REV is a scalar, return log of the specified revision if it exists + %return = %{ $self->{LOG}{$revs [0]} } if exists $self->{LOG}{$revs [0]}; + } + + return %return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $cm_branch->display_svnlog ($rev, [$wiki]); +# +# DESCRIPTION +# This method returns a string for displaying the log of the current branch +# at a $rev. If $wiki is set, returns a string for displaying in a Trac wiki +# table. The value of $wiki should be the Subversion URL of a FCM project +# associated with the intended Trac system. +# ------------------------------------------------------------------------------ + +sub display_svnlog { + my ($self, $rev, $wiki) = @_; + my $return = ''; + + my %log = $self->svnlog (REV => $rev); + + if ($wiki) { + # Output in Trac wiki format + # -------------------------------------------------------------------------- + $return .= '|| ' . &svn_date ($log{date}) . ' || ' . $log{author} . ' || '; + + my $trac_url = Fcm::Keyword::get_browser_url($self->url); + + # Get list of tickets from log + my @tickets; + while ($log{msg} =~ /(?:(\w+):)?(?:#|ticket:)(\d+)/g) { + push @tickets, [$1, $2]; + } + @tickets = sort { + if ($a->[0] and $b->[0]) { + $a->[0] cmp $b->[0] or $a->[1] <=> $b->[1]; + + } elsif ($a->[0]) { + 1; + + } else { + $a->[1] <=> $b->[1]; + } + } @tickets; + + if ($trac_url =~ m#^$wiki(?:/*|$)#) { + # URL is in the specified $wiki, use Trac link + $return .= '[' . $rev . '] ||'; + + for my $ticket (@tickets) { + $return .= ' '; + $return .= $ticket->[0] . ':' if $ticket->[0]; + $return .= '#' . $ticket->[1]; + } + + $return .= ' ||'; + + } else { + # URL is not in the specified $wiki, use full URL + my $rev_url = $trac_url; + $rev_url =~ s{/intertrac/source:.*\z}{/intertrac/changeset:$rev}xms; + $return .= '[' . $rev_url . ' ' . $rev . '] ||'; + + my $ticket_url = $trac_url; + $ticket_url =~ s{/intertrac/source:.*\z}{/intertrac/}xms; + + for my $ticket (@tickets) { + $return .= ' [' . $ticket_url; + $return .= $ticket->[0] . ':' if $ticket->[0]; + $return .= 'ticket:' . $ticket->[1] . ' ' . $ticket->[1] . ']'; + } + + $return .= ' ||'; + } + + } else { + # Output in plain text format + # -------------------------------------------------------------------------- + my @msg = split /\n/, $log{msg}; + my $line = (@msg > 1 ? ' lines' : ' line'); + + $return .= join ( + ' | ', + ('r' . $rev, $log{author}, &svn_date ($log{date}), scalar (@msg) . $line), + ); + $return .= "\n\n"; + $return .= $log{msg}; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @list = $cm_url->svnlist ([REV => $rev], [RECURSIVE => 1]); +# +# DESCRIPTION +# The method returns a list of paths as returned by "svn list". If RECURSIVE +# is set, "svn list" is invoked with the "-R" option. +# ------------------------------------------------------------------------------ + +sub svnlist { + my $self = shift; + my %args = @_; + + my $recursive = exists $args{RECURSIVE} ? $args{RECURSIVE} : 0; + my $rev = exists $args{REV} ? $args{REV} : undef; + my $key = $recursive ? 'RLIST' : 'LIST'; + + # Find out last changed revision of the current URL + $rev = $self->svninfo (FLAG => 'Last Changed Rev', REV => $rev); + return () if not $rev; + + # Get directory listing for the current URL at the last changed revision + if (not exists $self->{$key}{$rev}) { + my $rc; + + my @list = map {chomp; $_} &run_command ( + [qw/svn list -r/, $rev, ($recursive ? '-R' : ()), $self->url_peg], + METHOD => 'qx', ERROR => 'ignore', DEVNULL => 1, RC => \$rc, + ); + + $self->{$key}{$rev} = $rc ? undef : \@list; + } + + return (defined ($self->{$key}{$rev}) ? @{ $self->{$key}{$rev} } : undef); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @list = $cm_url->branch_list ($rev); +# +# DESCRIPTION +# The method returns a list of branches in the current project, assuming the +# FCM naming convention. If $rev if specified, it returns the list of +# branches at $rev. +# ------------------------------------------------------------------------------ + +sub branch_list { + my ($self, $rev) = @_; + + # Current URL must be a valid FCM project + return if not $self->project; + + # Find out last changed revision of the current URL + $rev = $self->svninfo (FLAG => 'Revision', REV => $rev); + return () if not $rev; + + if (not exists $self->{BRANCH_LIST}{$rev}) { + $self->{BRANCH_LIST}{$rev} = []; + + # Get URL of the project "branches/" sub-directory + my $url = Fcm::CmUrl->new (URL => $self->project_url . '/branches'); + + # List three levels underneath "branches/" + # First level, i.e. dev, test, pkg, etc + my @list1 = map {$url->url . '/' . $_} $url->svnlist (REV => $rev); + @list1 = grep m#/$#, @list1; + + # Second level, i.e. user name, Shared, Rel or Config + my @list2; + for (@list1) { + my $u = Fcm::CmUrl->new (URL => $_); + my @list = $u->svnlist (REV => $rev); + + push @list2, map {$u->url . $_} @list; + } + + # Third level, branch name + for (@list2) { + my $u = Fcm::CmUrl->new (URL => $_); + my @list = map {s#/*$##; $_} $u->svnlist (REV => $rev); + + push @{ $self->{BRANCH_LIST}{$rev} }, map {$u->url . $_} @list; + } + } + + return @{ $self->{BRANCH_LIST}{$rev} }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $self->_analyse_url (); +# +# DESCRIPTION +# The method analyses the current URL, breaking it up into the project +# (substring of URL up to the slash before "trunk", "branches" or "tags"), +# branch name ("trunk", "branches///" or "tags/") and +# the sub-directory below the top of the project sub-tree. It re-sets the +# corresponding interal variables. +# ------------------------------------------------------------------------------ + +sub _analyse_url { + my $self = shift; + my ($url, $project, $branch, $subdir, $pegrev); + + # Check that URL is set + $url = $self->url_peg; + return if not $url; + return if not $self->is_url; + + # Extract from URL the peg revision + $pegrev = $1 if $url =~ s/@($rev_pattern)$//i; + + if ($url =~ m#^(.*?)/+(trunk|branches|tags)(?:/+(.*))?/*$#) { + # URL is under the "trunk", a branch or a tag + $project = $1; + my ($branch_id, $remain) = ($2, $3); + + $remain = '' if not defined $remain; + + if ($branch_id eq 'trunk') { + # URL under the "trunk" + $branch = 'trunk'; + + } else { + # URL under a branch or a tag + $branch = $branch_id; + + # Assume "3 sub-directories", FCM branch naming convention + for (1 .. 3) { + if ($remain =~ s#^([^/]+)(?:/+|$)##) { + $branch .= '/' . $1; + + } else { + $branch = undef; + last; + } + } + } + + $subdir = $remain ? $remain : '' if $branch; + + } else { + # URL is at some level above the "trunk", a branch or a tag + # Use "svn ls" to determine whether it is a project URL + my @list = $self->svnlist (REV => ($pegrev ? $pegrev : 'HEAD')); + my %lines = map {chomp $_; ($_, 1)} @list; + + # A project URL should have the "trunk", "branches" and "tags" directories + ($project = $url) =~ s#/*$## + if $lines{'trunk/'} and $lines{'branches/'} and $lines{'tags/'}; + } + + $self->{PROJECT} = $project; + $self->{BRANCH} = $branch; + $self->{SUBDIR} = $subdir; + $self->{PEGREV} = $pegrev; + $self->{ANALYSED} = 1; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->root (); +# +# DESCRIPTION +# The method returns the repository root of the current URL. +# ------------------------------------------------------------------------------ + +sub root { + my $self = shift; + + return $self->svninfo (FLAG => 'Repository Root'); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->project_url_peg (); +# $cm_url->project_url_peg ($url); +# +# DESCRIPTION +# The method returns the URL@PEG of the "project" part of the current URL. If +# an argument is specified, the URL of the "project" part and the peg +# revision of the current URL are re-set. +# ------------------------------------------------------------------------------ + +sub project_url_peg { + my $self = shift; + + if (@_) { + my $url = shift; + + # Re-construct URL is necessary + if (! $self->project_url_peg or $url ne $self->project_url_peg) { + my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : ''; + + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $self->subdir if $self->subdir; + $url .= '@' . $pegrev if $pegrev; + + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{PROJECT} . ($self->pegrev ? '@' . $self->pegrev : ''); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->project_url (); +# $cm_url->project_url ($url); +# +# DESCRIPTION +# The method returns the URL of the "project" part of the current URL. If an +# argument is specified, the URL of the "project" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub project_url { + my $self = shift; + + if (@_) { + my $url = shift; + $url =~ s/@($rev_pattern)$//i; + + # Re-construct URL is necessary + if (! $self->project_url or $url ne $self->project_url) { + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $self->subdir if $self->subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{PROJECT}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->project_path (); +# $cm_url->project_path ($path); +# +# DESCRIPTION +# The method returns the path of the "project" part of the current URL. If an +# argument is specified, the path of the "project" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub project_path { + my $self = shift; + + # Repository root + my $root = $self->root; + $root = substr ( + $self->project_url, + 0, + length ($self->project_url) - length ($self->project) - 1 + ) if not $root; + + if (@_) { + my $path = shift; + + # Re-construct URL is necessary + if (! $self->project_path or $path ne $self->project_path) { + $path .= '/' . $self->branch if $self->branch; + $path .= '/' . $self->subdir if $self->subdir; + + $self->path ($path); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return substr ($self->{PROJECT}, length ($root)); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $name = $cm_url->project (); +# $cm_url->project ($name); +# +# DESCRIPTION +# The method returns the basename of the "project" part of the current URL. +# If an argument is specified, the basename of the "project" part of the +# current URL is re-set. +# ------------------------------------------------------------------------------ + +sub project { + my $self = shift; + + if (@_) { + my $name = shift; + + # Re-construct URL is necessary + if (! $self->project or $name ne $self->project) { + my $url = ''; + if ($self->project) { + $url = $self->project; + $url =~ s#/[^/]+$##; + + } else { + $url = $self->root; + } + + $url .= '/' . $name; + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $self->subdir if $self->subdir; + $url .= '@' . $self->pegrev if $self->pegrev; + + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + my $name = $self->{PROJECT}; + $name =~ s#^.*/([^/]+)$#$1# if $name; + + return $name; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->branch_url_peg (); +# $cm_url->branch_url_peg ($url); +# +# DESCRIPTION +# The method returns the URL@PEG of the "branch" part of the current URL. If +# an argument is specified, the URL@PEG of the "branch" part of the current +# URL is re-set. +# ------------------------------------------------------------------------------ + +sub branch_url_peg { + my $self = shift; + + if (@_) { + my $url = shift; + + # Re-construct URL is necessary + if (! $self->branch_url_peg or $url ne $self->branch_url_peg) { + my $pegrev = ($url =~ s/@($rev_pattern)$//i) ? $1 : ''; + + $url .= '/' . $self->subdir if $self->subdir; + $url .= '@' . $pegrev if $pegrev; + + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->project_url . '/' . $self->branch . + ($self->pegrev ? '@' . $self->pegrev : ''); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->branch_url (); +# $cm_url->branch_url ($url); +# +# DESCRIPTION +# The method returns the URL of the "branch" part of the current URL. If an +# argument is specified, the URL of the "branch" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub branch_url { + my $self = shift; + + if (@_) { + my $url = shift; + $url =~ s/@($rev_pattern)$//i; + + # Re-construct URL is necessary + if (! $self->branch_url or $url ne $self->branch_url) { + $url .= '/' . $self->subdir if $self->subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->project_url . '/' . $self->branch; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->branch_path (); +# $cm_url->branch_path ($path); +# +# DESCRIPTION +# The method returns the path of the "branch" part of the current URL. If an +# argument is specified, the path of the "branch" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub branch_path { + my $self = shift; + + if (@_) { + my $path = shift; + + # Re-construct URL is necessary + if (! $self->branch_path or $path ne $self->branch_path) { + $path .= '/' . $self->subdir if $self->subdir; + + $self->path ($path); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch ? $self->project_path . '/' . $self->branch : undef); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $branch = $cm_url->branch (); +# $cm_url->branch ($branch); +# +# DESCRIPTION +# The method returns the "branch" part of the current URL. If an argument is +# specified, the "branch" part of the current URL is re-set. +# ------------------------------------------------------------------------------ + +sub branch { + my $self = shift; + + if (@_) { + my $branch = shift; + + # Re-construct URL is necessary + if (! $self->branch or $branch ne $self->branch) { + my $url = $self->project_url; + $url .= '/' . $branch; + $url .= '/' . $self->subdir if $self->subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{BRANCH}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->branch_owner; +# +# DESCRIPTION +# This method returns the owner of the branch. +# ------------------------------------------------------------------------------ + +sub branch_owner { + my $self = shift; + my $return; + + if ($self->is_branch and $self->branch_url =~ m#/([^/]+)/[^/]+/*$#) { + my $user = $1; + $return = $user; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_trunk (); +# +# DESCRIPTION +# The method returns true if the the current URL is (a sub-tree of) the trunk. +# ------------------------------------------------------------------------------ + +sub is_trunk { + my $self = shift; + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch and $self->branch eq 'trunk'); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_branch (); +# +# DESCRIPTION +# The method returns true if the the current URL is (a sub-tree of) a branch. +# ------------------------------------------------------------------------------ + +sub is_branch { + my $self = shift; + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch and $self->branch =~ m#^branches/#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $cm_url->is_tag (); +# +# DESCRIPTION +# The method returns true if the the current URL is (a sub-tree of) a tag. +# ------------------------------------------------------------------------------ + +sub is_tag { + my $self = shift; + + $self->_analyse_url () if not $self->{ANALYSED}; + + return ($self->branch and $self->branch =~ m#^tags/#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $subdir = $cm_url->subdir (); +# $cm_url->subdir ($subdir); +# +# DESCRIPTION +# The method returns the "subdir" part of the current URL. If an argument is +# specified, the "subdir" part of the current URL is re-set. +# ------------------------------------------------------------------------------ + +sub subdir { + my $self = shift; + + if (@_) { + my $subdir = shift; + + # Re-construct URL is necessary + if (! $self->subdir or $subdir ne $self->subdir) { + my $url = $self->project_url; + $url .= '/' . $self->branch if $self->branch; + $url .= '/' . $subdir if $subdir; + + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{SUBDIR}; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = $cm_url->url (); +# $cm_url->url ($url); +# +# DESCRIPTION +# The method returns the URL without the "peg revision" part. If an argument +# is specified, the URL is re-set without modifying the "peg revision" part. +# ------------------------------------------------------------------------------ + +sub url { + my $self = shift; + + if (@_) { + my $url = shift; + $url =~ s/@($rev_pattern)$//i; + + # Re-construct URL if necessary + if (! $self->url or $url ne $self->url) { + $self->url_peg ($url . ($self->pegrev ? '@' . $self->pegrev : '')); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + (my $url = $self->url_peg) =~ s/@($rev_pattern)$//i; + + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->path (); +# $cm_url->path ($path); +# +# DESCRIPTION +# The method returns the "path" part of the URL (i.e. URL without the +# "root" part). If an argument is specified, the "path" part of the URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub path { + my $self = shift; + + # Repository root + my $root = $self->root; + $root = substr ( + $self->project_url, + 0, + length ($self->project_url) - length ($self->project) - 1 + ) if not $root; + + if (@_) { + my $path = shift; + $path =~ s/@($rev_pattern)$//i; + + # Re-construct URL is necessary + if (! $self->path or $path ne $self->path) { + my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path); + $self->url ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return substr ($self->url, length ($root)); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $path = $cm_url->path_peg (); +# $cm_url->path_peg ($path); +# +# DESCRIPTION +# The method returns the PATH@PEG part of the URL (i.e. URL without the +# "root" part). If an argument is specified, the PATH@PEG part of the URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub path_peg { + my $self = shift; + + # Repository root + my $root = $self->root; + $root = substr ( + $self->project_url, + 0, + length ($self->project_url) - length ($self->project) - 1 + ) if not $root; + + if (@_) { + my $path = shift; + + # Re-construct URL is necessary + if (! $self->path_peg or $path ne $self->path_peg) { + my $url = ($root . (substr ($path, 0, 1) eq '/' ? '' : '/') . $path); + $self->url_peg ($url); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return substr ($self->url_peg, length ($root)); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $cm_url->pegrev (); +# $cm_url->pegrev ($rev); +# +# DESCRIPTION +# The method returns the "peg revision" part of the current URL. If an +# argument is specified, the "peg revision" part of the current URL is +# re-set. +# ------------------------------------------------------------------------------ + +sub pegrev { + my $self = shift; + + if (@_) { + my $pegrev = shift; + + # Re-construct URL is necessary + if (! $self->pegrev or $pegrev ne $self->pegrev) { + $self->url_peg ($self->url . ($pegrev ? '@' . $pegrev : '')); + } + } + + $self->_analyse_url () if not $self->{ANALYSED}; + + return $self->{PEGREV}; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Config.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Config.pm new file mode 100644 index 0000000..aacdbf3 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Config.pm @@ -0,0 +1,894 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Config +# +# DESCRIPTION +# This is a class for reading and processing central and user configuration +# settings for FCM. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Config; + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use File::Basename; +use File::Spec::Functions; +use FindBin; +use POSIX qw/setlocale LC_ALL/; + +# FCM component modules +use Fcm::CfgFile; + +# Other declarations: +sub _get_hash_value; + +# Delimiter for setting and for list +our $DELIMITER = '::'; +our $DELIMITER_PATTERN = qr{::|/}; +our $DELIMITER_LIST = ','; + +my $INSTANCE; + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $config = Fcm::Config->instance(); +# +# DESCRIPTION +# Returns an instance of this class. +# ------------------------------------------------------------------------------ + +sub instance { + my ($class) = @_; + if (!defined($INSTANCE)) { + $INSTANCE = $class->new(); + $INSTANCE->get_config(); + $INSTANCE->is_initialising(0); + } + return $INSTANCE; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Config->new (VERBOSE => $verbose); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Config class. +# +# ARGUMENTS +# VERBOSE - Set the verbose level of diagnostic output +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + # Ensure that all subsequent Subversion output is in UK English + if (setlocale (LC_ALL, 'en_GB')) { + $ENV{LANG} = 'en_GB'; + } + + my $self = { + initialising => 1, + central_config => undef, + user_config => undef, + user_id => undef, + verbose => exists $args{VERBOSE} ? $args{VERBOSE} : undef, + variable => {}, + + # Primary settings + setting => { + # Current command + FCM_COMMAND => &basename ($0), + + # Current FCM release identifier + FCM_RELEASE => '1-5', + + # Location of file with the last changed revision of the FCM trunk + FCM_REV_FILE => catfile (dirname ($FindBin::Bin), 'etc', 'fcm_rev'), + + # Fortran BLOCKDATA dependencies + BLD_BLOCKDATA => {}, + + # Copy dummy target + BLD_CPDUMMY => '$(FCM_DONEDIR)/FCM_CP.dummy', + + # No dependency check + BLD_DEP_N => {}, + + # Additional (PP) dependencies + BLD_DEP => {}, + BLD_DEP_PP => {}, + + # Excluded dependency + BLD_DEP_EXCL => { + '' => [ + # Fortran intrinsic modules + 'USE' . $DELIMITER . 'ISO_C_BINDING', + 'USE' . $DELIMITER . 'IEEE_EXCEPTIONS', + 'USE' . $DELIMITER . 'IEEE_ARITHMETIC', + 'USE' . $DELIMITER . 'IEEE_FEATURES', + + # Fortran intrinsic subroutines + 'OBJ' . $DELIMITER . 'CPU_TIME', + 'OBJ' . $DELIMITER . 'GET_COMMAND', + 'OBJ' . $DELIMITER . 'GET_COMMAND_ARGUMENT', + 'OBJ' . $DELIMITER . 'GET_ENVIRONMENT_VARIABLE', + 'OBJ' . $DELIMITER . 'MOVE_ALLOC', + 'OBJ' . $DELIMITER . 'MVBITS', + 'OBJ' . $DELIMITER . 'RANDOM_NUMBER', + 'OBJ' . $DELIMITER . 'RANDOM_SEED', + 'OBJ' . $DELIMITER . 'SYSTEM_CLOCK', + + # Dummy statements + 'OBJ' . $DELIMITER . 'NONE', + 'EXE' . $DELIMITER . 'NONE', + ], + }, + + # Extra executable dependencies + BLD_DEP_EXE => {}, + + # Dependency pattern for each type + BLD_DEP_PATTERN => { + H => q/^#\s*include\s*['"](\S+)['"]/, + USE => q/^\s*use\s+(\w+)/, + INTERFACE => q/^#?\s*include\s+['"](\S+##OUTFILE_EXT/ . $DELIMITER . + q/INTERFACE##)['"]/, + INC => q/^\s*include\s+['"](\S+)['"]/, + OBJ => q#^\s*(?:/\*|!)\s*depends\s*on\s*:\s*(\S+)#, + EXE => q/^\s*(?:#|;)\s*(?:calls|list|if|interface)\s*:\s*(\S+)/, + }, + + # Rename main program targets + BLD_EXE_NAME => {}, + + # Rename library targets + BLD_LIB => {'' => 'fcm_default'}, + + # Name of Makefile and run environment shell script + BLD_MISC => { + 'BLDMAKEFILE' => 'Makefile', + 'BLDRUNENVSH' => 'fcm_env.sh', + }, + + # PP flags + BLD_PP => {}, + + # Custom source file type + BLD_TYPE => {}, + + # Types that always need to be built + BLD_TYPE_ALWAYS_BUILD => 'PVWAVE' . + $DELIMITER_LIST . 'GENLIST' . + $DELIMITER_LIST . 'SQL', + + # Dependency scan types + BLD_TYPE_DEP => { + FORTRAN => 'USE' . + $DELIMITER . 'INTERFACE' . + $DELIMITER . 'INC' . + $DELIMITER . 'OBJ', + FPP => 'USE' . + $DELIMITER . 'INTERFACE' . + $DELIMITER . 'INC' . + $DELIMITER . 'H' . + $DELIMITER . 'OBJ', + CPP => 'H' . + $DELIMITER . 'OBJ', + C => 'H' . + $DELIMITER . 'OBJ', + SCRIPT => 'EXE', + }, + + # Dependency scan types for pre-processing + BLD_TYPE_DEP_PP => { + FPP => 'H', + CPP => 'H', + C => 'H', + }, + + # Types that cannot have duplicated targets + BLD_TYPE_NO_DUPLICATED_TARGET => '', + + # BLD_VPATH, each value must be a comma separate list + # '' translates to % + # 'FLAG' translates to {OUTFILE_EXT}{FLAG} + BLD_VPATH => { + BIN => q{}, + ETC => 'ETC', + DONE => join($DELIMITER_LIST, qw{DONE IDONE}), + FLAGS => 'FLAGS', + INC => q{}, + LIB => 'LIB', + OBJ => 'OBJ', + }, + + # Cache basename + CACHE => '.config', + CACHE_DEP => '.config_dep', + CACHE_DEP_PP => '.config_dep_pp', + CACHE_FILE_SRC => '.config_file_src', + + # Types of "inc" statements expandable CFG files + CFG_EXP_INC => 'BLD' . + $DELIMITER_LIST . 'EXT' . + $DELIMITER_LIST . 'FCM', + + # Configuration file labels that can be declared more than once + CFG_KEYWORD => 'USE' . + $DELIMITER_LIST . 'INC' . + $DELIMITER_LIST . 'TARGET' . + $DELIMITER_LIST . 'BLD_DEP_EXCL', + + # Labels for all types of FCM configuration files + CFG_LABEL => { + CFGFILE => 'CFG', # config file information + INC => 'INC', # "include" from an configuration file + + # Labels for central/user internal config setting + SETTING => 'SET', + + # Labels for systems that allow inheritance + DEST => 'DEST', # destination + USE => 'USE', # use (inherit) a previous configuration + + # Labels for bld and pck cfg + TARGET => 'TARGET', # BLD: declare targets, PCK: target of source file + + # Labels for bld cfg + BLD_BLOCKDATA => 'BLOCKDATA', # declare Fortran BLOCKDATA dependencies + BLD_DEP => 'DEP', # additional dependencies + BLD_DEP_N => 'NO_DEP', # no dependency check + BLD_DEP_EXCL => 'EXCL_DEP', # exclude automatic dependencies + BLD_DEP_EXE => 'EXE_DEP', # declare dependencies for program + BLD_EXE_NAME => 'EXE_NAME', # rename a main program + BLD_LIB => 'LIB', # rename library + BLD_PP => 'PP', # sub-package needs pre-process? + BLD_TYPE => 'SRC_TYPE', # custom source file type + DIR => 'DIR', # DEPRECATED, same as DEST + INFILE_EXT => 'INFILE_EXT', # change input file name extension type + INHERIT => 'INHERIT', # inheritance flag + NAME => 'NAME', # name the build + OUTFILE_EXT => 'OUTFILE_EXT', # change output file type extension + FILE => 'SRC', # declare a sub-package + SEARCH_SRC => 'SEARCH_SRC', # search src/ sub-directory? + TOOL => 'TOOL', # declare a tool + + # Labels for ext cfg + BDECLARE => 'BLD', # build declaration + CONFLICT => 'CONFLICT', # set conflict mode + DIRS => 'SRC', # declare source directory + EXPDIRS => 'EXPSRC', # declare expandable source directory + MIRROR => 'MIRROR', # DEPRECATED, same as RDEST::MIRROR_CMD + OVERRIDE => 'OVERRIDE', # DEPRECATED, replaced by CONFLICT + RDEST => 'RDEST', # declare remote destionation + REVISION => 'REVISION', # declare branch revision in a project + REVMATCH => 'REVMATCH', # branch revision must match changed revision + REPOS => 'REPOS', # declare branch in a project + VERSION => 'VERSION', # DEPRECATED, same as REVISION + }, + + # Default names of known FCM configuration files + CFG_NAME => { + BLD => 'bld.cfg', # build configuration file + EXT => 'ext.cfg', # extract configuration file + PARSED => 'parsed_', # as-parsed configuration file prefix + }, + + # Latest version of known FCM configuration files + CFG_VERSION => { + BLD => '1.0', # bld cfg + EXT => '1.0', # ext cfg + }, + + # Standard sub-directories for extract/build + DIR => { + BIN => 'bin', # executable + BLD => 'bld', # build + CACHE => '.cache', # cache + CFG => 'cfg', # configuration + DONE => 'done', # "done" + ETC => 'etc', # miscellaneous items + FLAGS => 'flags', # "flags" + INC => 'inc', # include + LIB => 'lib', # library + OBJ => 'obj', # object + PPSRC => 'ppsrc', # pre-processed source + SRC => 'src', # source + TMP => 'tmp', # temporary directory + }, + + # A flag to indicate whether the revision of a given branch for extract + # must match with the revision of a changed revision of the branch + EXT_REVMATCH => 0, # default is false (allow any revision) + + # Input file name extension and type + # (may overlap with output (below) and vpath (above)) + INFILE_EXT => { + # General extensions + 'f' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'for' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'ftn' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'f77' => 'FORTRAN' . + $DELIMITER . 'SOURCE', + 'f90' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'SOURCE', + 'f95' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'SOURCE', + 'F' => 'FPP' . + $DELIMITER . 'SOURCE', + 'FOR' => 'FPP' . + $DELIMITER . 'SOURCE', + 'FTN' => 'FPP' . + $DELIMITER . 'SOURCE', + 'F77' => 'FPP' . + $DELIMITER . 'SOURCE', + 'F90' => 'FPP' . + $DELIMITER . 'FPP9X' . + $DELIMITER . 'SOURCE', + 'F95' => 'FPP' . + $DELIMITER . 'FPP9X' . + $DELIMITER . 'SOURCE', + 'c' => 'C' . + $DELIMITER . 'SOURCE', + 'cpp' => 'C' . + $DELIMITER . 'C++' . + $DELIMITER . 'SOURCE', + 'h' => 'CPP' . + $DELIMITER . 'INCLUDE', + 'o' => 'BINARY' . + $DELIMITER . 'OBJ', + 'obj' => 'BINARY' . + $DELIMITER . 'OBJ', + 'exe' => 'BINARY' . + $DELIMITER . 'EXE', + 'a' => 'BINARY' . + $DELIMITER . 'LIB', + 'sh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'ksh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'bash' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'csh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'pl' => 'SCRIPT' . + $DELIMITER . 'PERL', + 'pm' => 'SCRIPT' . + $DELIMITER . 'PERL', + 'py' => 'SCRIPT' . + $DELIMITER . 'PYTHON', + 'tcl' => 'SCRIPT' . + $DELIMITER . 'TCL', + 'pro' => 'SCRIPT' . + $DELIMITER . 'PVWAVE', + + # Local extensions + 'cfg' => 'CFGFILE', + 'h90' => 'CPP' . + $DELIMITER . 'INCLUDE', + 'inc' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'INCLUDE', + 'interface' => 'FORTRAN' . + $DELIMITER . 'FORTRAN9X' . + $DELIMITER . 'INCLUDE' . + $DELIMITER . 'INTERFACE', + }, + + # Ignore input files matching the following names (comma-separated list) + INFILE_IGNORE => 'fcm_env.ksh' . + $DELIMITER_LIST . 'fcm_env.sh', + + # Input file name pattern and type + INFILE_PAT => { + '\w+Scr_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL', + '\w+Comp_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENTASK', + '\w+(?:IF|Interface)_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENIF', + '\w+Suite_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENSUITE', + '\w+List_\w+' => 'SCRIPT' . + $DELIMITER . 'SHELL' . + $DELIMITER . 'GENLIST', + '\w+Sql_\w+' => 'SCRIPT' . + $DELIMITER . 'SQL', + }, + + # Input text file pattern and type + INFILE_TXT => { + '(?:[ck]|ba)?sh' => 'SCRIPT' . + $DELIMITER . 'SHELL', + 'perl' => 'SCRIPT' . + $DELIMITER . 'PERL', + 'python' => 'SCRIPT' . + $DELIMITER . 'PYTHON', + 'tcl(?:sh)?|wish' => 'SCRIPT' . + $DELIMITER . 'TCL', + }, + + # Lock file + LOCK => { + BLDLOCK => 'fcm.bld.lock', # build lock file + EXTLOCK => 'fcm.ext.lock', # extract lock file + }, + + # Output file type and extension + # (may overlap with input and vpath (above)) + OUTFILE_EXT => { + CFG => '.cfg', # FCM configuration file + DONE => '.done', # "done" files for compiled source + ETC => '.etc', # "etc" dummy file + EXE => '.exe', # binary executables + FLAGS => '.flags', # "flags" files, compiler flags config + IDONE => '.idone', # "done" files for included source + INTERFACE => '.interface', # interface for F90 subroutines/functions + LIB => '.a', # archive object library + MOD => '.mod', # compiled Fortran module information files + OBJ => '.o', # compiled object files + PDONE => '.pdone', # "done" files for pre-processed files + TAR => '.tar', # TAR archive + }, + + # Build commands and options (i.e. tools) + TOOL => { + SHELL => '/bin/sh', # Default shell + + CPP => 'cpp', # C pre-processor + CPPFLAGS => '-C', # CPP flags + CPP_INCLUDE => '-I', # CPP flag, specify "include" path + CPP_DEFINE => '-D', # CPP flag, define macro + CPPKEYS => '', # CPP keys (definition macro) + + CC => 'cc', # C compiler + CFLAGS => '', # CC flags + CC_COMPILE => '-c', # CC flag, compile only + CC_OUTPUT => '-o', # CC flag, specify output file name + CC_INCLUDE => '-I', # CC flag, specify "include" path + CC_DEFINE => '-D', # CC flag, define macro + + FPP => 'cpp', # Fortran pre-processor + FPPFLAGS => '-P -traditional', # FPP flags + FPP_INCLUDE => '-I', # FPP flag, specify "include" path + FPP_DEFINE => '-D', # FPP flag, define macro + FPPKEYS => '', # FPP keys (definition macro) + + FC => 'f90', # Fortran compiler + FFLAGS => '', # FC flags + FC_COMPILE => '-c', # FC flag, compile only + FC_OUTPUT => '-o', # FC flag, specify output file name + FC_INCLUDE => '-I', # FC flag, specify "include" path + FC_MODSEARCH => '', # FC flag, specify "module" path + FC_DEFINE => '-D', # FC flag, define macro + + LD => '', # linker + LDFLAGS => '', # LD flags + LD_OUTPUT => '-o', # LD flag, specify output file name + LD_LIBSEARCH => '-L', # LD flag, specify "library" path + LD_LIBLINK => '-l', # LD flag, specify link library + + AR => 'ar', # library archiver + ARFLAGS => 'rs', # AR flags + + MAKE => 'make', # make command + MAKEFLAGS => '', # make flags + MAKE_FILE => '-f', # make flag, path to Makefile + MAKE_SILENT => '-s', # make flag, silent diagnostic + MAKE_JOB => '-j', # make flag, number of jobs + + INTERFACE => 'file', # name interface after file/program + GENINTERFACE => '', # Fortran 9x interface generator + + DIFF3 => 'diff3', # extract diff3 merge + DIFF3FLAGS => '-E -m', # DIFF3 flags + GRAPHIC_DIFF => 'xxdiff', # graphical diff tool + GRAPHIC_MERGE=> 'xxdiff', # graphical merge tool + }, + + # List of tools that are local to FCM, (will not be exported to a Makefile) + TOOL_LOCAL => 'CPP' . + $DELIMITER_LIST . 'CPPFLAGS' . + $DELIMITER_LIST . 'CPP_INCLUDE' . + $DELIMITER_LIST . 'CPP_DEFINE' . + $DELIMITER_LIST . 'DIFF3' . + $DELIMITER_LIST . 'DIFF3_FLAGS' . + $DELIMITER_LIST . 'FPP' . + $DELIMITER_LIST . 'FPPFLAGS' . + $DELIMITER_LIST . 'FPP_INCLUDE' . + $DELIMITER_LIST . 'FPP_DEFINE' . + $DELIMITER_LIST . 'GRAPHIC_DIFF' . + $DELIMITER_LIST . 'GRAPHIC_MERGE' . + $DELIMITER_LIST . 'MAKE' . + $DELIMITER_LIST . 'MAKEFLAGS' . + $DELIMITER_LIST . 'MAKE_FILE' . + $DELIMITER_LIST . 'MAKE_SILENT' . + $DELIMITER_LIST . 'MAKE_JOB' . + $DELIMITER_LIST . 'INTERFACE' . + $DELIMITER_LIST . 'GENINTERFACE' . + $DELIMITER_LIST . 'MIRROR' . + $DELIMITER_LIST . 'REMOTE_SHELL', + + # List of tools that allow sub-package declarations + TOOL_PACKAGE => 'CPPFLAGS' . + $DELIMITER_LIST . 'CPPKEYS' . + $DELIMITER_LIST . 'CFLAGS' . + $DELIMITER_LIST . 'FPPFLAGS' . + $DELIMITER_LIST . 'FPPKEYS' . + $DELIMITER_LIST . 'FFLAGS' . + $DELIMITER_LIST . 'LD' . + $DELIMITER_LIST . 'LDFLAGS' . + $DELIMITER_LIST . 'INTERFACE' . + $DELIMITER_LIST . 'GENINTERFACE', + + # Supported tools for compilable source + TOOL_SRC_PP => { + FPP => { + COMMAND => 'FPP', + FLAGS => 'FPPFLAGS', + PPKEYS => 'FPPKEYS', + INCLUDE => 'FPP_INCLUDE', + DEFINE => 'FPP_DEFINE', + }, + + C => { + COMMAND => 'CPP', + FLAGS => 'CPPFLAGS', + PPKEYS => 'CPPKEYS', + INCLUDE => 'CPP_INCLUDE', + DEFINE => 'CPP_DEFINE', + }, + }, + + # Supported tools for compilable source + TOOL_SRC => { + FORTRAN => { + COMMAND => 'FC', + FLAGS => 'FFLAGS', + OUTPUT => 'FC_OUTPUT', + INCLUDE => 'FC_INCLUDE', + }, + + FPP => { + COMMAND => 'FC', + FLAGS => 'FFLAGS', + PPKEYS => 'FPPKEYS', + OUTPUT => 'FC_OUTPUT', + INCLUDE => 'FC_INCLUDE', + DEFINE => 'FC_DEFINE', + }, + + C => { + COMMAND => 'CC', + FLAGS => 'CFLAGS', + PPKEYS => 'CPPKEYS', + OUTPUT => 'CC_OUTPUT', + INCLUDE => 'CC_INCLUDE', + DEFINE => 'CC_DEFINE', + }, + }, + + # FCM URL keyword and prefix, FCM revision keyword, and FCM Trac URL + URL => {}, + URL_REVISION => {}, + + URL_BROWSER_MAPPING => {}, + URL_BROWSER_MAPPING_DEFAULT => { + LOCATION_COMPONENT_PATTERN + => qr{\A // ([^/]+) /+ ([^/]+)_svn /+(.*) \z}xms, + BROWSER_URL_TEMPLATE + => 'http://{1}/projects/{2}/intertrac/source:{3}{4}', + BROWSER_REV_TEMPLATE => '@{1}', + }, + + # Default web browser + WEB_BROWSER => 'firefox', + }, + }; + + # Backward compatibility: the REPOS setting is equivalent to the URL setting + $self->{setting}{REPOS} = $self->{setting}{URL}; + + # Alias the REVISION and TRAC setting to URL_REVISION and URL_TRAC + $self->{setting}{REVISION} = $self->{setting}{URL_REVISION}; + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in the "new" method. +# ------------------------------------------------------------------------------ + +for my $name (qw/central_config user_config user_id verbose/) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'central_config') { + # Central configuration file + if (-r catfile (dirname ($FindBin::Bin), 'etc', 'fcm.cfg')) { + $self->{$name} = catfile ( + dirname ($FindBin::Bin), 'etc', 'fcm.cfg' + ); + + } elsif (-r catfile ($FindBin::Bin, 'fcm.cfg')) { + $self->{$name} = catfile ($FindBin::Bin, 'fcm.cfg'); + } + + } elsif ($name eq 'user_config') { + # User configuration file + my $home = (getpwuid ($<))[7]; + $home = $ENV{HOME} if not defined $home; + $self->{$name} = catfile ($home, '.fcm') + if defined ($home) and -r catfile ($home, '.fcm'); + + } elsif ($name eq 'user_id') { + # User ID of current process + my $user = (getpwuid ($<))[0]; + $user = $ENV{LOGNAME} if not defined $user; + $user = $ENV{USER} if not defined $user; + $self->{$name} = $user; + + } elsif ($name eq 'verbose') { + # Verbose mode + $self->{$name} = exists $ENV{FCM_VERBOSE} ? $ENV{FCM_VERBOSE} : 1; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = $obj->is_initialising(); +# +# DESCRIPTION +# Returns true if this object is initialising. +# ------------------------------------------------------------------------------ +sub is_initialising { + my ($self, $value) = @_; + if (defined($value)) { + $self->{initialising} = $value; + } + return $self->{initialising}; +} + + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in the "new" method. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (qw/variable/) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $setting = $obj->setting (@labels); +# $obj->setting (\@labels, $setting); +# +# DESCRIPTION +# This method returns/sets an item under the setting hash table. The depth +# within the hash table is given by the list of arguments @labels, which +# should match with the keys in the multi-dimension setting hash table. +# ------------------------------------------------------------------------------ + +sub setting { + my $self = shift; + + if (@_) { + my $arg1 = shift; + my $s = $self->{setting}; + + if (ref ($arg1) eq 'ARRAY') { + # Assign setting + # ------------------------------------------------------------------------ + my $value = shift; + + while (defined (my $label = shift @$arg1)) { + if (exists $s->{$label}) { + if (ref $s->{$label} eq 'HASH') { + $s = $s->{$label}; + + } else { + $s->{$label} = $value; + last; + } + + } else { + if (@$arg1) { + $s->{$label} = {}; + $s = $s->{$label}; + + } else { + $s->{$label} = $value; + } + } + } + + } else { + # Get setting + # ------------------------------------------------------------------------ + return _get_hash_value ($s->{$arg1}, @_) if exists $s->{$arg1}; + } + } + + return undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj->get_config (); +# +# DESCRIPTION +# This method reads the configuration settings from the central and the user +# configuration files. +# ------------------------------------------------------------------------------ + +sub get_config { + my $self = shift; + + $self->_read_config_file ($self->central_config); + $self->_read_config_file ($self->user_config); + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj->_read_config_file (); +# +# DESCRIPTION +# This internal method reads a configuration file and assign values to the +# attributes of the current instance. +# ------------------------------------------------------------------------------ + +sub _read_config_file { + my $self = shift; + my $config_file = $_[0]; + + if (!$config_file || !-f $config_file || !-r $config_file) { + return; + } + + my $cfgfile = Fcm::CfgFile->new (SRC => $config_file, TYPE => 'FCM'); + $cfgfile->read_cfg (); + + LINE: for my $line (@{ $cfgfile->lines }) { + next unless $line->label; + + # "Environment variables" start with $ + if ($line->label =~ /^\$([A-Za-z_]\w*)$/) { + $ENV{$1} = $line->value; + next LINE; + } + + # "Settings variables" start with "set" + if ($line->label_starts_with_cfg ('SETTING')) { + my @tags = $line->label_fields; + shift @tags; + @tags = map {uc} @tags; + $self->setting (\@tags, $line->value); + next LINE; + } + + # Not a standard setting variable, put in internal variable list + (my $label = $line->label) =~ s/^\%//; + $self->variable ($label, $line->value); + } + + 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $ref = _get_hash_value (arg1, arg2, ...); +# +# DESCRIPTION +# This internal method recursively gets a value from a multi-dimensional +# hash. +# ------------------------------------------------------------------------------ + +sub _get_hash_value { + my $value = shift; + + while (defined (my $arg = shift)) { + if (exists $value->{$arg}) { + $value = $value->{$arg}; + + } else { + return undef; + } + } + + return $value; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ConfigSystem.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ConfigSystem.pm new file mode 100644 index 0000000..6231425 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ConfigSystem.pm @@ -0,0 +1,735 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ConfigSystem +# +# DESCRIPTION +# This is the base class for FCM systems that are based on inherited +# configuration files, e.g. the extract and the build systems. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::ConfigSystem; +use base qw{Fcm::Base}; + +use strict; +use warnings; + +use Fcm::CfgFile; +use Fcm::CfgLine; +use Fcm::Dest; +use Fcm::Util qw{expand_tilde e_report w_report}; +use Sys::Hostname qw{hostname}; + +# List of property methods for this class +my @scalar_properties = ( + 'cfg', # configuration file + 'cfg_methods', # list of sub-methods for parse_cfg + 'cfg_prefix', # optional prefix in configuration declaration + 'dest', # destination for output + 'inherit', # list of inherited configurations + 'inherited', # list of inheritance hierarchy + 'type', # system type +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ConfigSystem->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ConfigSystem class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + bless $self, $class; + + # List of sub-methods for parse_cfg + $self->cfg_methods ([qw/header inherit dest/]); + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'cfg') { + # New configuration file + $self->{$name} = Fcm::CfgFile->new (TYPE => $self->type); + + } elsif ($name =~ /^(?:cfg_methods|inherit|inherited)$/) { + # Reference to an array + $self->{$name} = []; + + } elsif ($name eq 'cfg_prefix' or $name eq 'type') { + # Reference to an array + $self->{$name} = ''; + + } elsif ($name eq 'dest') { + # New destination + $self->{$name} = Fcm::Dest->new (TYPE => $self->type); + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $out_of_date) = $obj->check_cache (); +# +# DESCRIPTION +# This method returns $rc = 1 on success or undef on failure. It returns +# $out_of_date = 1 if current cache file is out of date relative to those in +# inherited runs or 0 otherwise. +# ------------------------------------------------------------------------------ + +sub check_cache { + my $self = shift; + + my $rc = 1; + my $out_of_date = 0; + + if (@{ $self->inherit } and -f $self->dest->cache) { + # Get modification time of current cache file + my $cur_mtime = (stat ($self->dest->cache))[9]; + + # Compare with modification times of inherited cache files + for my $use (@{ $self->inherit }) { + next unless -f $use->dest->cache; + my $use_mtime = (stat ($use->dest->cache))[9]; + $out_of_date = 1 if $use_mtime > $cur_mtime; + } + } + + return ($rc, $out_of_date); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->check_lock (); +# +# DESCRIPTION +# This method returns true if no lock is found in the destination or if the +# locks found are allowed. +# ------------------------------------------------------------------------------ + +sub check_lock { + my $self = shift; + + # Check all types of locks + for my $method (@Fcm::Dest::lockfiles) { + my $lock = $self->dest->$method; + + # Check whether lock exists + next unless -e $lock; + + # Check whether this lock is allowed + next if $self->check_lock_is_allowed ($lock); + + # Throw error if a lock exists + w_report 'ERROR: ', $lock, ': lock file exists,'; + w_report ' ', $self->dest->rootdir, ': destination is busy.'; + return; + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->check_lock_is_allowed ($lock); +# +# DESCRIPTION +# This method returns true if it is OK for $lock to exist in the destination. +# ------------------------------------------------------------------------------ + +sub check_lock_is_allowed { + my ($self, $lock) = @_; + + # Disallow all types of locks by default + return 0; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->compare_setting ( +# METHOD_LIST => \@method_list, +# [METHOD_ARGS => \@method_args,] +# [CACHEBASE => $cachebase,] +# ); +# +# DESCRIPTION +# This method gets settings from the previous cache and updates the current. +# +# METHOD +# The method returns true on success. @method_list must be a list of method +# names for processing the cached lines in the previous run. If an existing +# cache exists, its content is read into $old_lines, which is a list of +# Fcm::CfgLine objects. Otherwise, $old_lines is set to undef. If $cachebase +# is set, it is used for as the cache basename. Otherwise, the default for +# the current system is used. It calls each method in the @method_list using +# $self->$method ($old_lines, @method_args), which should return a +# two-element list. The first element should be a return code (1 for out of +# date, 0 for up to date and undef for failure). The second element should be +# a reference to a list of Fcm::CfgLine objects for the output. +# ------------------------------------------------------------------------------ + +sub compare_setting { + my ($self, %args) = @_; + + my @method_list = exists ($args{METHOD_LIST}) ? @{ $args{METHOD_LIST} } : (); + my @method_args = exists ($args{METHOD_ARGS}) ? @{ $args{METHOD_ARGS} } : (); + my $cachebase = exists ($args{CACHEBASE}) ? $args{CACHEBASE} : undef; + + my $rc = 1; + + # Read cache if the file exists + # ---------------------------------------------------------------------------- + my $cache = $cachebase + ? File::Spec->catfile ($self->dest->cachedir, $cachebase) + : $self->dest->cache; + my @in_caches = (); + if (-r $cache) { + push @in_caches, $cache; + + } else { + for my $use (@{ $self->inherit }) { + my $use_cache = $cachebase + ? File::Spec->catfile ($use->dest->cachedir, $cachebase) + : $use->dest->cache; + push @in_caches, $use_cache if -r $use_cache; + } + } + + my $old_lines = undef; + for my $in_cache (@in_caches) { + next unless -r $in_cache; + my $cfg = Fcm::CfgFile->new (SRC => $in_cache); + + if ($cfg->read_cfg) { + $old_lines = [] if not defined $old_lines; + push @$old_lines, @{ $cfg->lines }; + } + } + + # Call methods in @method_list to see if cache is out of date + # ---------------------------------------------------------------------------- + my @new_lines = (); + my $out_of_date = 0; + for my $method (@method_list) { + my ($return, $lines); + ($return, $lines) = $self->$method ($old_lines, @method_args) if $rc; + + if (defined $return) { + # Method succeeded + push @new_lines, @$lines; + $out_of_date = 1 if $return; + + } else { + # Method failed + $rc = $return; + last; + } + } + + # Update the cache in the current run + # ---------------------------------------------------------------------------- + if ($rc) { + if (@{ $self->inherited } and $out_of_date) { + # If this is an inherited configuration, the cache must not be changed + w_report 'ERROR: ', $self->cfg->src, + ': inherited configuration does not match with its cache.'; + $rc = undef; + + } elsif ((not -f $cache) or $out_of_date) { + my $cfg = Fcm::CfgFile->new; + $cfg->lines ([sort {$a->label cmp $b->label} @new_lines]); + $rc = $cfg->print_cfg ($cache, 1); + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($changed_hash_ref, $new_lines_array_ref) = +# $self->compare_setting_in_config($prefix, \@old_lines); +# +# DESCRIPTION +# This method compares old and current settings for a specified item. +# +# METHOD +# This method does two things. +# +# It uses the current configuration for the $prefix item to generate a list of +# new Fcm::CfgLine objects (which is returned as a reference in the second +# element of the returned list). +# +# The values of the old lines are then compared with those of the new lines. +# Any settings that are changed are stored in a hash, which is returned as a +# reference in the first element of the returned list. The key of the hash is +# the name of the changed setting, and the value is the value of the new +# setting or undef if the setting no longer exists. +# +# ARGUMENTS +# $prefix - the name of an item in Fcm::Config to be compared +# @old_lines - a list of Fcm::CfgLine objects containing the old settings +# ------------------------------------------------------------------------------ + +sub compare_setting_in_config { + my ($self, $prefix, $old_lines_ref) = @_; + + my %changed = %{$self->setting($prefix)}; + my (@new_lines, %new_val_of); + while (my ($key, $val) = each(%changed)) { + $new_val_of{$key} = (ref($val) eq 'ARRAY' ? join(q{ }, sort(@{$val})) : $val); + push(@new_lines, Fcm::CfgLine->new( + LABEL => $prefix . $Fcm::Config::DELIMITER . $key, + VALUE => $new_val_of{$key}, + )); + } + + if (defined($old_lines_ref)) { + my %old_val_of + = map {($_->label_from_field(1), $_->value())} # converts into a hash + grep {$_->label_starts_with($prefix)} # gets relevant lines + @{$old_lines_ref}; + + while (my ($key, $val) = each(%old_val_of)) { + if (exists($changed{$key})) { + if ($val eq $new_val_of{$key}) { # no change from old to new + delete($changed{$key}); + } + } + else { # exists in old but not in new + $changed{$key} = undef; + } + } + } + + return (\%changed, \@new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->invoke ([CLEAN => 1, ]%args); +# +# DESCRIPTION +# This method invokes the system. If CLEAN is set to true, it will only parse +# the configuration and set up the destination, but will not invoke the +# system. See the invoke_setup_dest and the invoke_system methods for list of +# other arguments in %args. +# ------------------------------------------------------------------------------ + +sub invoke { + my $self = shift; + my %args = @_; + + # Print diagnostic at beginning of run + # ---------------------------------------------------------------------------- + # Name of the system + (my $name = ref ($self)) =~ s/^Fcm:://; + + # Print start time on system run, if verbose is true + my $date = localtime; + print $name, ' command started on ', $date, '.', "\n" + if $self->verbose; + + # Start time (seconds since epoch) + my $otime = time; + + # Parse the configuration file + my $rc = $self->invoke_stage ('Parse configuration', 'parse_cfg'); + + # Set up the destination + $rc = $self->invoke_stage ('Setup destination', 'invoke_setup_dest', %args) + if $rc; + + # Invoke the system + # ---------------------------------------------------------------------------- + $rc = $self->invoke_system (%args) if $rc and not $args{CLEAN}; + + # Remove empty directories + $rc = $self->dest->clean (MODE => 'EMPTY') if $rc; + + # Print diagnostic at end of run + # ---------------------------------------------------------------------------- + # Print lapse time at the end, if verbose is true + if ($self->verbose) { + my $total = time - $otime; + my $s_str = $total > 1 ? 'seconds' : 'second'; + print '->TOTAL: ', $total, ' ', $s_str, "\n"; + } + + # Report end of system run + $date = localtime; + if ($rc) { + # Success + print $name, ' command finished on ', $date, '.', "\n" + if $self->verbose; + + } else { + # Failure + e_report $name, ' failed on ', $date, '.'; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->invoke_setup_dest ([CLEAN|FULL => 1], [IGNORE_LOCK => 1]); +# +# DESCRIPTION +# This method sets up the destination and returns true on success. +# +# ARGUMENTS +# CLEAN|FULL - If set to "true", set up the system in "clean|full" mode. +# Sub-directories and files in the root directory created by +# the previous invocation of the system will be removed. If +# not set, the default is to run in "incremental" mode. +# IGNORE_LOCK - If set to "true", it ignores any lock files that may exist in +# the destination root directory. +# ------------------------------------------------------------------------------ + +sub invoke_setup_dest { + my $self = shift; + my %args = @_; + + # Set up destination + # ---------------------------------------------------------------------------- + # Print destination in verbose mode + if ($self->verbose()) { + printf( + "Destination: %s@%s:%s\n", + scalar(getpwuid($<)), + hostname(), + $self->dest()->rootdir(), + ); + } + + my $rc = 1; + my $out_of_date = 0; + + # Check whether lock exists in the destination root + $rc = $self->check_lock if $rc and not $args{IGNORE_LOCK}; + + # Check whether current cache is out of date relative to the inherited ones + ($rc, $out_of_date) = $self->check_cache if $rc; + + # Remove sub-directories and files in destination in "full" mode + $rc = $self->dest->clean (MODE => 'ALL') + if $rc and ($args{FULL} or $args{CLEAN} or $out_of_date); + + # Create build root directory if necessary + $rc = $self->dest->create if $rc; + + # Set a lock in the destination root + $rc = $self->dest->set_lock if $rc; + + # Generate an as-parsed configuration file + $self->cfg->print_cfg ($self->dest->parsedcfg); + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_stage ($name, $method, @args); +# +# DESCRIPTION +# This method invokes a named stage of the system, where $name is the name of +# the stage, $method is the name of the method for invoking the stage and +# @args are the arguments to the &method. +# ------------------------------------------------------------------------------ + +sub invoke_stage { + my ($self, $name, $method, @args) = @_; + + # Print diagnostic at beginning of a stage + print '->', $name, ': start', "\n" if $self->verbose; + my $stime = time; + + # Invoke the stage + my $rc = $self->$method (@args); + + # Print diagnostic at end of a stage + my $total = time - $stime; + my $s_str = $total > 1 ? 'seconds' : 'second'; + print '->', $name, ': ', $total, ' ', $s_str, "\n"; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_system (%args); +# +# DESCRIPTION +# This is a prototype method for invoking the system. +# ------------------------------------------------------------------------------ + +sub invoke_system { + my $self = shift; + my %args = @_; + + print "Dummy code.\n"; + + return 0; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->parse_cfg (); +# +# DESCRIPTION +# This method calls other methods to parse the configuration file. +# ------------------------------------------------------------------------------ + +sub parse_cfg { + my $self = shift; + + return unless $self->cfg->src; + + # Read config file + # ---------------------------------------------------------------------------- + return unless $self->cfg->read_cfg; + + if ($self->cfg->type ne $self->type) { + w_report 'ERROR: ', $self->cfg->src, ': not a ', $self->type, + ' config file.'; + return; + } + + # Strip out optional prefix from all labels + # ---------------------------------------------------------------------------- + if ($self->cfg_prefix) { + for my $line (@{ $self->cfg->lines }) { + $line->prefix ($self->cfg_prefix); + } + } + + # Filter lines from the configuration file + # ---------------------------------------------------------------------------- + my @cfg_lines = grep { + $_->slabel and # ignore empty/comment lines + index ($_->slabel, '%') != 0 and # ignore user variable + not $_->slabel_starts_with_cfg ('INC') # ignore INC line + } @{ $self->cfg->lines }; + + # Parse the lines to read in the various settings, by calling the methods: + # $self->parse_cfg_XXX, where XXX is: header, inherit, dest, and the values + # in the list @{ $self->cfg_methods }. + # ---------------------------------------------------------------------------- + my $rc = 1; + for my $name (@{ $self->cfg_methods }) { + my $method = 'parse_cfg_' . $name; + $self->$method (\@cfg_lines) or $rc = 0; + } + + # Report warnings/errors + # ---------------------------------------------------------------------------- + for my $line (@cfg_lines) { + $rc = 0 if not $line->parsed; + my $mesg = $line->format_error; + w_report $mesg if $mesg; + } + + return ($rc); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_dest (\@cfg_lines); +# +# DESCRIPTION +# This method parses the destination settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_dest { + my ($self, $cfg_lines) = @_; + + my $rc = 1; + + # DEST/DIR declarations + # ---------------------------------------------------------------------------- + my @lines = grep { + $_->slabel_starts_with_cfg ('DEST') or $_->slabel_starts_with_cfg ('DIR') + } @$cfg_lines; + + # Only ROOTDIR declarations are accepted + for my $line (@lines) { + my ($d, $method) = $line->slabel_fields; + $d = lc $d; + $method = lc $method; + + # Backward compatibility + $d = 'dest' if $d eq 'dir'; + + # Default to "rootdir" + $method = 'rootdir' if (not $method) or $method eq 'root'; + + # Only "rootdir" can be set + next unless $method eq 'rootdir'; + + $self->$d->$method (&expand_tilde ($line->value)); + $line->parsed (1); + } + + # Make sure root directory is set + # ---------------------------------------------------------------------------- + if (not $self->dest->rootdir) { + w_report 'ERROR: ', $self->cfg->actual_src, + ': destination root directory not set.'; + $rc = 0; + } + + # Inherit destinations + # ---------------------------------------------------------------------------- + for my $use (@{ $self->inherit }) { + push @{ $self->dest->inherit }, (@{ $use->dest->inherit }, $use->dest); + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_header (\@cfg_lines); +# +# DESCRIPTION +# This method parses the header setting in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_header { + my ($self, $cfg_lines) = @_; + + # Set header lines as "parsed" + map {$_->parsed (1)} grep {$_->slabel_starts_with_cfg ('CFGFILE')} @$cfg_lines; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_inherit (\@cfg_lines); +# +# DESCRIPTION +# This method parses the inherit setting in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_inherit { + my ($self, $cfg_lines) = @_; + + # USE declaration + # ---------------------------------------------------------------------------- + my @lines = grep {$_->slabel_starts_with_cfg ('USE')} @$cfg_lines; + + # Check for cyclic dependency + if (@lines and grep {$_ eq $self->cfg->actual_src} @{ $self->inherited }) { + # Error if current configuration file is in its own inheritance hierarchy + w_report 'ERROR: ', $self->cfg->actual_src, ': attempt to inherit itself.'; + $_->error ($_->label . ': ignored due to cyclic dependency.') for (@lines); + return 0; + } + + my $rc = 1; + + for my $line (@lines) { + # Invoke new instance of the current class + my $use = ref ($self)->new; + + # Set configuration file, inheritance hierarchy + # and attempt to parse the configuration + $use->cfg->src (&expand_tilde ($line->value)); + $use->inherited ([$self->cfg->actual_src, @{ $self->inherited }]); + $use->parse_cfg; + + # Add to list of inherit configurations + push @{ $self->inherit }, $use; + + $line->parsed (1); + } + + # Check locks in inherited destination + # ---------------------------------------------------------------------------- + for my $use (@{ $self->inherit }) { + $rc = 0 unless $use->check_lock; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines (); +# +# DESCRIPTION +# This method returns the configuration lines of this object. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self) = @_; + + my @inherited_dests = map { + Fcm::CfgLine->new ( + label => $self->cfglabel ('USE'), value => $_->dest->rootdir + ); + } @{ $self->inherit }; + + return ( + Fcm::CfgLine::comment_block ('File header'), + Fcm::CfgLine->new ( + label => $self->cfglabel ('CFGFILE') . $Fcm::Config::DELIMITER . 'TYPE', + value => $self->type, + ), + Fcm::CfgLine->new ( + label => $self->cfglabel ('CFGFILE') . $Fcm::Config::DELIMITER . 'VERSION', + value => '1.0', + ), + Fcm::CfgLine->new (), + + @inherited_dests, + + Fcm::CfgLine::comment_block ('Destination'), + ($self->dest->to_cfglines()), + ); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Dest.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Dest.pm new file mode 100644 index 0000000..21e22a2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Dest.pm @@ -0,0 +1,887 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Dest +# +# DESCRIPTION +# This class contains methods to set up a destination location of an FCM +# extract/build. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use warnings; +use strict; + +package Fcm::Dest; +use base qw{Fcm::Base}; + +use Carp qw{croak} ; +use Cwd qw{cwd} ; +use Fcm::CfgLine ; +use Fcm::Timer qw{timestamp_command} ; +use Fcm::Util qw{run_command touch_file w_report}; +use File::Basename qw{basename dirname} ; +use File::Find qw{find} ; +use File::Path qw{mkpath rmtree} ; +use File::Spec ; +use Sys::Hostname qw{hostname} ; +use Text::ParseWords qw{shellwords} ; + +# Useful variables +# ------------------------------------------------------------------------------ +# List of configuration files +our @cfgfiles = ( + 'bldcfg', # default location of the build configuration file + 'extcfg', # default location of the extract configuration file +); + +# List of cache and configuration files, according to the dest type +our @cfgfiles_type = ( + 'cache', # default location of the cache file + 'cfg', # default location of the configuration file + 'parsedcfg', # default location of the as-parsed configuration file +); + +# List of lock files +our @lockfiles = ( + 'bldlock', # the build lock file + 'extlock', # the extract lock file +); + +# List of misc files +our @miscfiles_bld = ( + 'bldrunenvsh', # the build run environment shell script + 'bldmakefile', # the build Makefile +); + +# List of sub-directories created by extract +our @subdirs_ext = ( + 'cfgdir', # sub-directory for configuration files + 'srcdir', # sub-directory for source tree +); + +# List of sub-directories that can be archived by "tar" at end of build +our @subdirs_tar = ( + 'donedir', # sub-directory for "done" files + 'flagsdir', # sub-directory for "flags" files + 'incdir', # sub-directory for include files + 'ppsrcdir', # sub-directory for pre-process source tree + 'objdir', # sub-directory for object files +); + +# List of sub-directories created by build +our @subdirs_bld = ( + 'bindir', # sub-directory for executables + 'etcdir', # sub-directory for miscellaneous files + 'libdir', # sub-directory for object libraries + 'tmpdir', # sub-directory for temporary build files + @subdirs_tar, # -see above- +); + +# List of sub-directories under rootdir +our @subdirs = ( + 'cachedir', # sub-directory for caches + @subdirs_ext, # -see above- + @subdirs_bld, # -see above- +); + +# List of inherited search paths +# "rootdir" + all @subdirs, with "XXXdir" replaced with "XXXpath" +our @paths = ( + 'rootpath', + (map {my $key = $_; $key =~ s{dir\z}{path}msx; $key} @subdirs), +); + +# List of properties and their default values. +my %PROP_OF = ( + # the original destination (if current destination is a mirror) + 'dest0' => undef, + # list of inherited Fcm::Dest objects + 'inherit' => [], + # remote login name + 'logname' => scalar(getpwuid($<)), + # lock file + 'lockfile' => undef, + # remote machine + 'machine' => hostname(), + # mirror command to use + 'mirror_cmd' => 'rsync', + # (for rsync) remote mkdir, the remote shell command + 'rsh_mkdir_rsh' => 'ssh', + # (for rsync) remote mkdir, the remote shell command flags + 'rsh_mkdir_rshflags' => '-n -oBatchMode=yes', + # (for rsync) remote mkdir, the remote shell command + 'rsh_mkdir_mkdir' => 'mkdir', + # (for rsync) remote mkdir, the remote shell command flags + 'rsh_mkdir_mkdirflags' => '-p', + # (for rsync) remote mkdir, the remote shell command + 'rsync' => 'rsync', + # (for rsync) remote mkdir, the remote shell command flags + 'rsyncflags' => q{-a --exclude='.*' --delete-excluded} + . q{ --timeout=900 --rsh='ssh -oBatchMode=yes'}, + # destination root directory + 'rootdir' => undef, + # destination type, "bld" (default) or "ext" + 'type' => 'bld', +); +# Hook for property setter +my %PROP_HOOK_OF = ( + 'inherit' => \&_reset_inherit, + 'rootdir' => \&_reset_rootdir, +); + +# Mirror implementations +my %MIRROR_IMPL_OF = ( + rdist => \&_mirror_with_rdist, + rsync => \&_mirror_with_rsync, +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Dest->new(%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Dest class. See above for +# allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my ($class, %args) = @_; + my $self = bless(Fcm::Base->new(%args), $class); + while (my ($key, $value) = each(%args)) { + $key = lc($key); + if (exists($PROP_OF{$key})) { + $self->{$key} = $value; + } + } + for my $key (@subdirs, @paths, @lockfiles, @cfgfiles) { + $self->{$key} = undef; + } + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $self->DESTROY; +# +# DESCRIPTION +# This method is called automatically when the Fcm::Dest object is +# destroyed. +# ------------------------------------------------------------------------------ + +sub DESTROY { + my $self = shift; + + # Remove the lockfile if it is set + unlink $self->lockfile if $self->lockfile and -w $self->lockfile; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X($value); +# +# DESCRIPTION +# Details of these properties are explained in %PROP_OF. +# ------------------------------------------------------------------------------ + +while (my ($key, $default) = each(%PROP_OF)) { + no strict 'refs'; + *{$key} = sub { + my $self = shift(); + # Set property to specified value + if (@_) { + $self->{$key} = $_[0]; + if (exists($PROP_HOOK_OF{$key})) { + $PROP_HOOK_OF{$key}->($self, $key); + } + } + # Sets default where possible + if (!defined($self->{$key})) { + $self->{$key} = $default; + } + return $self->{$key}; + }; +} + +# Remote shell property: deprecated. +sub remote_shell { + my $self = shift(); + $self->rsh_mkdir_rsh(@_); +} + +# Resets properties associated with root directory. +sub _reset_rootdir { + my $self = shift(); + for my $key (@cfgfiles, @lockfiles, @miscfiles_bld, @subdirs) { + $self->{$key} = undef; + } +} + +# Reset properties associated with inherited paths. +sub _reset_inherit { + my $self = shift(); + for my $key (@paths) { + $self->{$key} = undef; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# +# DESCRIPTION +# This method returns X, where X is a location derived from rootdir, and can +# be one of: +# bindir, bldcfg, blddir, bldlock, bldrunenv, cache, cachedir, cfg, cfgdir, +# donedir, etcdir, extcfg, extlock, flagsdir, incdir, libdir, parsedcfg, +# ppsrcdir, objdir, or tmpdir. +# +# Details of these properties are explained earlier. +# ------------------------------------------------------------------------------ + +for my $name (@cfgfiles, @cfgfiles_type, @lockfiles, @miscfiles_bld, @subdirs) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # If variable not set, derive it from rootdir + if ($self->rootdir and not defined $self->{$name}) { + if ($name eq 'cache') { + # Cache file under root/.cache + $self->{$name} = File::Spec->catfile ( + $self->cachedir, $self->setting ('CACHE'), + ); + + } elsif ($name eq 'cfg') { + # Configuration file of current type + my $method = $self->type . 'cfg'; + $self->{$name} = $self->$method; + + } elsif (grep {$name eq $_} @cfgfiles) { + # Configuration files under the root/cfg + (my $label = uc ($name)) =~ s/CFG//; + $self->{$name} = File::Spec->catfile ( + $self->cfgdir, $self->setting ('CFG_NAME', $label), + ); + + } elsif (grep {$name eq $_} @lockfiles) { + # Lock file + $self->{$name} = File::Spec->catfile ( + $self->rootdir, $self->setting ('LOCK', uc ($name)), + ); + + } elsif (grep {$name eq $_} @miscfiles_bld) { + # Misc file + $self->{$name} = File::Spec->catfile ( + $self->rootdir, $self->setting ('BLD_MISC', uc ($name)), + ); + + } elsif ($name eq 'parsedcfg') { + # As-parsed configuration file of current type + $self->{$name} = File::Spec->catfile ( + dirname ($self->cfg), + $self->setting (qw/CFG_NAME PARSED/) . basename ($self->cfg), + ) + + } elsif (grep {$name eq $_} @subdirs) { + # Sub-directories under the root + (my $label = uc ($name)) =~ s/DIR//; + $self->{$name} = File::Spec->catfile ( + $self->rootdir, + $self->setting ('DIR', $label), + ($name eq 'cachedir' ? '.' . $self->type : ()), + ); + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# +# DESCRIPTION +# This method returns X, an array containing the search path of a destination +# directory, which can be one of: +# binpath, bldpath, cachepath, cfgpath, donepath, etcpath, flagspath, +# incpath, libpath, ppsrcpath, objpath, rootpath, srcpath, or tmppath, +# +# Details of these properties are explained earlier. +# ------------------------------------------------------------------------------ + +for my $name (@paths) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + (my $dir = $name) =~ s/path/dir/; + + if ($self->$dir and not defined $self->{$name}) { + my @path = (); + + # Recursively inherit the search path + for my $d (@{ $self->inherit }) { + unshift @path, $d->$dir; + } + + # Place the path of the current build in the front + unshift @path, $self->$dir; + + $self->{$name} = \@path; + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->archive (); +# +# DESCRIPTION +# This method creates TAR archives for selected sub-directories. +# ------------------------------------------------------------------------------ + +sub archive { + my $self = shift; + + # Save current directory + my $cwd = cwd (); + + my $tar = $self->setting (qw/OUTFILE_EXT TAR/); + my $verbose = $self->verbose; + + for my $name (@subdirs_tar) { + my $dir = $self->$name; + + # Ignore unless sub-directory exists + next unless -d $dir; + + # Change to container directory + my $base = basename ($dir); + print 'cd ', dirname ($dir), "\n" if $verbose > 2; + chdir dirname ($dir); + + # Run "tar" command + my $rc = &run_command ( + [qw/tar -czf/, $base . $tar, $base], + PRINT => $verbose > 1, ERROR => 'warn', + ); + + # Remove sub-directory + &run_command ([qw/rm -rf/, $base], PRINT => $verbose > 1) if not $rc; + } + + # Change back to "current" directory + print 'cd ', $cwd, "\n" if $verbose > 2; + chdir $cwd; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $authority = $obj->authority(); +# +# DESCRIPTION +# Returns LOGNAME@MACHINE for this destination if LOGNAME is defined and not +# the same as the user ID of the current process. Returns MACHINE if LOGNAME +# is the same as the user ID of the current process, but MACHINE is not the +# same as the current hostname. Returns an empty string if LOGNAME and +# MACHINE are not defined or are the same as in the current process. +# ------------------------------------------------------------------------------ + +sub authority { + my $self = shift; + my $return = ''; + + if ($self->logname ne $self->config->user_id) { + $return = $self->logname . '@' . $self->machine; + + } elsif ($self->machine ne &hostname()) { + $return = $self->machine; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->clean([ITEM => ,] [MODE => 'ALL|CONTENT|EMPTY',]); +# +# DESCRIPTION +# This method removes files/directories from the destination. If ITEM is set, +# it must be a reference to a list of method names for files/directories to +# be removed. Otherwise, the list is determined by the destination type. If +# MODE is ALL, all directories/files created by the extract/build are +# removed. If MODE is CONTENT, only contents within sub-directories are +# removed. If MODE is EMPTY (default), only empty sub-directories are +# removed. +# ------------------------------------------------------------------------------ + +sub clean { + my ($self, %args) = @_; + my $mode = exists $args{MODE} ? $args{MODE} : 'EMPTY'; + my $rc = 1; + my @names + = $args{ITEM} ? @{$args{ITEM}} + : $self->type() eq 'ext' ? ('cachedir', @subdirs_ext) + : ('cachedir', @subdirs_bld, @miscfiles_bld) + ; + my @items; + if ($mode eq 'CONTENT') { + for my $name (@names) { + my $item = $self->$name(); + push(@items, _directory_contents($item)); + } + } + else { + for my $name (@names) { + my $item = $self->$name(); + if ($mode eq 'ALL' || -d $item && !_directory_contents($item)) { + push(@items, $item); + } + } + } + for my $item (@items) { + if ($self->verbose() >= 2) { + printf("%s: remove\n", $item); + } + eval {rmtree($item)}; + if ($@) { + w_report($@); + $rc = 0; + } + } + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->create ([DIR => ,]); +# +# DESCRIPTION +# This method creates the directories of a destination. If DIR is set, it +# must be a reference to a list of sub-directories to be created. Otherwise, +# the sub-directory list is determined by the destination type. It returns +# true if the destination is created or if it exists and is writable. +# ------------------------------------------------------------------------------ + +sub create { + my ($self, %args) = @_; + + my $rc = 1; + + my @dirs; + if (exists $args{DIR} and $args{DIR}) { + # Create only selected sub-directories + @dirs = @{ $args{DIR} }; + + } else { + # Create rootdir, cachedir and read-write sub-directories for extract/build + @dirs = ( + qw/rootdir cachedir/, + ($self->type eq 'ext' ? @subdirs_ext : @subdirs_bld), + ); + } + + for my $name (@dirs) { + my $dir = $self->$name; + + # Create directory if it does not already exist + if (not -d $dir) { + print 'Make directory: ', $dir, "\n" if $self->verbose > 1; + mkpath $dir; + } + + # Check whether directory exists and is writable + unless (-d $dir and -w $dir) { + w_report 'ERROR: ', $dir, ': cannot write to destination.'; + $rc = 0; + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->create_bldrunenvsh (); +# +# DESCRIPTION +# This method creates the runtime environment script for the build. +# ------------------------------------------------------------------------------ + +sub create_bldrunenvsh { + my $self = shift; + + # Path to executable files and directory for misc files + my @bin_paths = grep {_directory_contents($_)} @{$self->binpath()}; + my $bin_dir = -d $self->bindir() ? $self->bindir() : undef; + my $etc_dir = _directory_contents($self->etcdir()) ? $self->etcdir() : undef; + + # Create a runtime environment script if necessary + if (@bin_paths || $etc_dir) { + my $path = $self->bldrunenvsh(); + open(my $handle, '>', $path) || croak("$path: cannot open ($!)\n"); + printf($handle "#!%s\n", $self->setting(qw/TOOL SHELL/)); + if (@bin_paths) { + printf($handle "PATH=%s:\$PATH\n", join(':', @bin_paths)); + print($handle "export PATH\n"); + } + if ($etc_dir) { + printf($handle "FCM_ETCDIR=%s\n", $etc_dir); + print($handle "export FCM_ETCDIR\n"); + } + close($handle) || croak("$path: cannot close ($!)\n"); + + # Create symbolic links fcm_env.ksh and bin/fcm_env.ksh for backward + # compatibility + my $FCM_ENV_KSH = 'fcm_env.ksh'; + for my $link ( + File::Spec->catfile($self->rootdir, $FCM_ENV_KSH), + ($bin_dir ? File::Spec->catfile($bin_dir, $FCM_ENV_KSH) : ()), + ) { + if (-l $link && readlink($link) ne $path || -e $link) { + unlink($link); + } + if (!-l $link) { + symlink($path, $link) || croak("$link: cannot create symbolic link\n"); + } + } + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->dearchive (); +# +# DESCRIPTION +# This method extracts from TAR archives for selected sub-directories. +# ------------------------------------------------------------------------------ + +sub dearchive { + my $self = shift; + + my $tar = $self->setting (qw/OUTFILE_EXT TAR/); + my $verbose = $self->verbose; + + # Extract archives if necessary + for my $name (@subdirs_tar) { + my $tar_file = $self->$name . $tar; + + # Check whether tar archive exists for the named sub-directory + next unless -f $tar_file; + + # If so, extract the archive and remove it afterwards + &run_command ([qw/tar -xzf/, $tar_file], PRINT => $verbose > 1); + &run_command ([qw/rm -f/, $tar_file], PRINT => $verbose > 1); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $name = $obj->get_pkgname_of_path ($path); +# +# DESCRIPTION +# This method returns the package name of $path if $path is in (a relative +# path of) $self->srcdir, or undef otherwise. +# ------------------------------------------------------------------------------ + +sub get_pkgname_of_path { + my ($self, $path) = @_; + + my $relpath = File::Spec->abs2rel ($path, $self->srcdir); + my $name = $relpath ? [File::Spec->splitdir ($relpath)] : undef; + + return $name; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %src = $obj->get_source_files (); +# +# DESCRIPTION +# This method returns a hash (keys = package names, values = file names) +# under $self->srcdir. +# ------------------------------------------------------------------------------ + +sub get_source_files { + my $self = shift; + + my %src; + if ($self->srcdir and -d $self->srcdir) { + &find (sub { + return if /^\./; # ignore system/hidden file + return if -d $File::Find::name; # ignore directory + return if not -r $File::Find::name; # ignore unreadable files + + my $name = join ( + '__', @{ $self->get_pkgname_of_path ($File::Find::name) }, + ); + $src{$name} = $File::Find::name; + }, $self->srcdir); + } + + return \%src; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->mirror (\@items); +# +# DESCRIPTION +# This method mirrors @items (list of method names for directories or files) +# from $dest0 (which must be an instance of Fcm::Dest for a local +# destination) to this destination. +# ------------------------------------------------------------------------------ + +sub mirror { + my ($self, $items_ref) = @_; + if ($self->authority() || $self->dest0()->rootdir() ne $self->rootdir()) { + # Diagnostic + if ($self->verbose()) { + printf( + "Destination: %s\n", + ($self->authority() ? $self->authority() . q{:} : q{}) . $self->rootdir() + ); + } + if ($MIRROR_IMPL_OF{$self->mirror_cmd()}) { + $MIRROR_IMPL_OF{$self->mirror_cmd()}->($self, $self->dest0(), $items_ref); + } + else { + # Unknown mirroring tool + w_report($self->mirror_cmd, ': unknown mirroring tool, abort.'); + return 0; + } + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->_mirror_with_rdist ($dest0, \@items); +# +# DESCRIPTION +# This internal method implements $self->mirror with "rdist". +# ------------------------------------------------------------------------------ + +sub _mirror_with_rdist { + my ($self, $dest0, $items) = @_; + + my $rhost = $self->authority ? $self->authority : &hostname(); + + # Print distfile content to temporary file + my @distfile = (); + for my $label (@$items) { + push @distfile, '( ' . $dest0->$label . ' ) -> ' . $rhost . "\n"; + push @distfile, ' install ' . $self->$label . ';' . "\n"; + } + + # Set up mirroring command (use "rdist" at the moment) + my $command = 'rdist -R'; + $command .= ' -q' unless $self->verbose > 1; + $command .= ' -f - 1>/dev/null'; + + # Diagnostic + my $croak = 'Cannot execute "' . $command . '"'; + if ($self->verbose > 2) { + print timestamp_command ($command, 'Start'); + print ' ', $_ for (@distfile); + } + + # Execute the mirroring command + open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort'; + for my $line (@distfile) { + print COMMAND $line; + } + close COMMAND or croak $croak, ' (', $?, '), abort'; + + # Diagnostic + print timestamp_command ($command, 'End ') if $self->verbose > 2; + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->_mirror_with_rsync($dest0, \@items); +# +# DESCRIPTION +# This internal method implements $self->mirror() with "rsync". +# ------------------------------------------------------------------------------ + +sub _mirror_with_rsync { + my ($self, $dest0, $items_ref) = @_; + my @rsh_mkdir; + if ($self->authority()) { + @rsh_mkdir = ( + $self->rsh_mkdir_rsh(), + shellwords($self->rsh_mkdir_rshflags()), + $self->authority(), + $self->rsh_mkdir_mkdir(), + shellwords($self->rsh_mkdir_mkdirflags()), + ); + } + my @rsync = ($self->rsync(), shellwords($self->rsyncflags())); + my @rsync_verbose = ($self->verbose() > 2 ? '-v' : ()); + my $auth = $self->authority() ? $self->authority() . q{:} : q{}; + for my $item (@{$items_ref}) { + # Create container directory, as rsync does not do it automatically + my $dir = dirname($self->$item()); + if (@rsh_mkdir) { + run_command([@rsh_mkdir, $dir], TIME => $self->verbose() > 2); + } + else { + mkpath($dir); + } + run_command( + [@rsync, @rsync_verbose, $dest0->$item(), $auth . $dir], + TIME => $self->verbose > 2, + ); + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->set_lock (); +# +# DESCRIPTION +# This method sets a lock in the current destination. +# ------------------------------------------------------------------------------ + +sub set_lock { + my $self = shift; + + $self->lockfile (); + + if ($self->type eq 'ext' and not $self->dest0) { + # Only set an extract lock for the local destination + $self->lockfile ($self->extlock); + + } elsif ($self->type eq 'bld') { + # Set a build lock + $self->lockfile ($self->bldlock); + } + + return &touch_file ($self->lockfile) if $self->lockfile; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines ([$index]); +# +# DESCRIPTION +# This method returns a list of configuration lines for the current +# destination. If it is set, $index is the index number of the current +# destination. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self, $index) = @_; + + my $PREFIX = $self->cfglabel($self->dest0() ? 'RDEST' : 'DEST'); + my $SUFFIX = ($index ? $Fcm::Config::DELIMITER . $index : q{}); + + my @return = ( + Fcm::CfgLine->new(label => $PREFIX . $SUFFIX, value => $self->rootdir()), + ); + if ($self->dest0()) { + for my $name (qw{ + logname + machine + mirror_cmd + rsh_mkdir_rsh + rsh_mkdir_rshflags + rsh_mkdir_mkdir + rsh_mkdir_mkdirflags + rsync + rsyncflags + }) { + if ($self->{$name} && $self->{$name} ne $PROP_OF{$name}) { # not default + push( + @return, + Fcm::CfgLine->new( + label => $PREFIX . $Fcm::Config::DELIMITER . uc($name) . $SUFFIX, + value => $self->{$name}, + ), + ); + } + } + } + + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = $obj->write_rules (); +# +# DESCRIPTION +# This method returns a string containing Makefile variable declarations for +# directories and search paths in this destination. +# ------------------------------------------------------------------------------ + +sub write_rules { + my $self = shift; + my $return = ''; + + # FCM_*DIR* + for my $i (0 .. @{ $self->inherit }) { + for my $name (@paths) { + (my $label = $name) =~ s/path$/dir/; + my $dir = $name eq 'rootpath' ? $self->$name->[$i] : File::Spec->catfile ( + '$(FCM_ROOTDIR' . ($i ? $i : '') . ')', + File::Spec->abs2rel ($self->$name->[$i], $self->rootpath->[$i]), + ); + + $return .= ($i ? '' : 'export ') . 'FCM_' . uc ($label) . ($i ? $i : '') . + ' := ' . $dir . "\n"; + } + } + + # FCM_*PATH + for my $name (@paths) { + (my $label = $name) =~ s/path$/dir/; + + $return .= 'export FCM_' . uc ($name) . ' := '; + for my $i (0 .. @{ $self->$name } - 1) { + $return .= ($i ? ':' : '') . '$(FCM_' . uc ($label) . ($i ? $i : '') . ')'; + } + $return .= "\n"; + } + + $return .= "\n"; + + return $return; +} + +# Returns contents in directory. +sub _directory_contents { + my $path = shift(); + if (!-d $path) { + return; + } + opendir(my $handle, $path) || croak("$path: cannot open directory ($!)\n"); + my @items = grep {$_ ne q{.} && $_ ne q{..}} readdir($handle); + closedir($handle); + map {File::Spec->catfile($path . $_)} @items; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Exception.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Exception.pm new file mode 100644 index 0000000..3320309 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Exception.pm @@ -0,0 +1,95 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Exception; +use overload (q{""} => \&as_string); + +use Scalar::Util qw{blessed}; + +# ------------------------------------------------------------------------------ +# Returns true if $e is a blessed instance of this class. +sub caught { + my ($class, $e) = @_; + return (blessed($e) && $e->isa($class)); +} + +# ------------------------------------------------------------------------------ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless( + {message => q{unknown problem}, ($args_ref ? %{$args_ref} : ())}, + $class, + ); +} + +# ------------------------------------------------------------------------------ +# Returns a string representation of this exception +sub as_string { + my ($self) = @_; + return sprintf("%s: %s\n", blessed($self), $self->get_message()); +} + +# ------------------------------------------------------------------------------ +# Returns the message of this exception +sub get_message { + my ($self) = @_; + return $self->{message}; +} + +1; +__END__ + +=head1 NAME + +Fcm::Exception + +=head1 SYNOPSIS + + use Fcm::Exception; + eval { + croak(Fcm::Exception->new({message => $message})); + }; + if ($@) { + if (Fcm::Exception->caught($@)) { + print({STDERR} $@); + } + } + +=head1 DESCRIPTION + +This exception is raised when there is a generic problem in FCM. + +=head1 METHODS + +=over 4 + +=item $class->caught($e) + +Returns true if $e is a blessed instance of this class. + +=item $class->new({message=E$message}) + +Returns a new instance of this exception. Its first argument must be a +reference to a hash containing the detailed I of the exception. + +=item $e->as_string() + +Returns a string representation of this exception. + +=item $e->get_message() + +Returns the detailed message of this exception. + +=back + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Extract.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Extract.pm new file mode 100644 index 0000000..f4665eb --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Extract.pm @@ -0,0 +1,1118 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Extract +# +# DESCRIPTION +# This is the top level class for the FCM extract system. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Extract; +@ISA = qw(Fcm::ConfigSystem); + +# Standard pragma +use warnings; +use strict; + +# Standard modules +use File::Path; +use File::Spec; + +# FCM component modules +use Fcm::CfgFile; +use Fcm::CfgLine; +use Fcm::Config; +use Fcm::ConfigSystem; +use Fcm::Dest; +use Fcm::ExtractFile; +use Fcm::ExtractSrc; +use Fcm::Keyword; +use Fcm::ReposBranch; +use Fcm::SrcDirLayer; +use Fcm::Util; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'bdeclare', # list of build declarations + 'branches', # list of repository branches + 'conflict', # conflict mode + 'rdest' , # remote destination information +); + +# List of hash property methods for this class +my @hash_properties = ( + 'srcdirs' , # list of source directory extract info + 'files', # list of files processed key=pkgname, value=Fcm::ExtractFile +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::Extract->new; +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::Extract class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::ConfigSystem->new (%args); + + $self->{$_} = undef for (@scalar_properties); + + $self->{$_} = {} for (@hash_properties); + + bless $self, $class; + + # List of sub-methods for parse_cfg + push @{ $self->cfg_methods }, (qw/rdest bld conflict project/); + + # System type + $self->type ('ext'); + + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'bdeclare' or $name eq 'branches') { + # Reference to an array + $self->{$name} = []; + + } elsif ($name eq 'rdest') { + # New extract destination local/remote + $self->{$name} = Fcm::Dest->new (DEST0 => $self->dest(), TYPE => 'ext'); + + } elsif ($name eq 'conflict') { + # Conflict mode, default to "merge" + $self->{$name} = 'merge'; + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->check_lock_is_allowed ($lock); +# +# DESCRIPTION +# This method returns true if it is OK for $lock to exist in the destination. +# ------------------------------------------------------------------------------ + +sub check_lock_is_allowed { + my ($self, $lock) = @_; + + # Allow existence of build lock in inherited extract + return ($lock eq $self->dest->bldlock and @{ $self->inherited }); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_extract (); +# +# DESCRIPTION +# This method invokes the extract stage of the extract system. It returns +# true on success. +# ------------------------------------------------------------------------------ + +sub invoke_extract { + my $self = shift; + + my $rc = 1; + + my @methods = ( + 'expand_cfg', # expand URL, revision keywords, relative path, etc + 'create_dir_stack', # analyse the branches to create an extract sequence + 'extract_src', # use the sequence to extract source to destination + 'write_cfg', # generate final configuration file + 'write_cfg_bld', # generate build configuration file + ); + + for my $method (@methods) { + $rc = $self->$method if $rc; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_mirror (); +# +# DESCRIPTION +# This method invokes the mirror stage of the extract system. It returns +# true on success. +# ------------------------------------------------------------------------------ + +sub invoke_mirror { + my $self = shift; + return $self->rdest->mirror ([qw/bldcfg extcfg srcdir/]); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->invoke_system (); +# +# DESCRIPTION +# This method invokes the extract system. It returns true on success. +# ------------------------------------------------------------------------------ + +sub invoke_system { + my $self = shift; + + my $rc = 1; + + $rc = $self->invoke_stage ('Extract', 'invoke_extract'); + $rc = $self->invoke_stage ('Mirror', 'invoke_mirror') + if $rc and $self->rdest->rootdir; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_rdest(\@cfg_lines); +# +# DESCRIPTION +# This method parses the remote destination settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_rdest { + my ($self, $cfg_lines_ref) = @_; + + # RDEST declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg('RDEST')} @{$cfg_lines_ref}) { + my ($d, $method) = map {lc($_)} $line->slabel_fields(); + $method ||= 'rootdir'; + if ($self->rdest()->can($method)) { + $self->rdest()->$method(expand_tilde($line->value())); + $line->parsed(1); + } + } + + # MIRROR declaration, deprecated = RDEST::MIRROR_CMD + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg('MIRROR')} @{$cfg_lines_ref}) { + $self->rdest()->mirror_cmd($line->value()); + $line->parsed(1); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_bld (\@cfg_lines); +# +# DESCRIPTION +# This method parses the build configurations in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_bld { + my ($self, $cfg_lines) = @_; + + # BLD declarations + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('BDECLARE')} @$cfg_lines) { + # Remove BLD from label + my @words = $line->slabel_fields; + + # Check that a declaration follows BLD + next if @words <= 1; + + push @{ $self->bdeclare }, Fcm::CfgLine->new ( + LABEL => join ($Fcm::Config::DELIMITER, @words), + PREFIX => $self->cfglabel ('BDECLARE'), + VALUE => $line->value, + ); + $line->parsed (1); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_conflict (\@cfg_lines); +# +# DESCRIPTION +# This method parses the conflict settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_conflict { + my ($self, $cfg_lines) = @_; + + # Deprecated: Override mode setting + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('OVERRIDE')} @$cfg_lines) { + next if ($line->slabel_fields) > 1; + $self->conflict ($line->bvalue ? 'override' : 'fail'); + $line->parsed (1); + $line->warning($line->slabel . ' is deprecated. Use ' . + $line->cfglabel('CONFLICT') . ' override|merge|fail.'); + } + + # Conflict mode setting + # ---------------------------------------------------------------------------- + my @conflict_modes = qw/fail merge override/; + my $conflict_modes_pattern = join ('|', @conflict_modes); + for my $line (grep {$_->slabel_starts_with_cfg ('CONFLICT')} @$cfg_lines) { + if ($line->value =~ /$conflict_modes_pattern/i) { + $self->conflict (lc ($line->value)); + $line->parsed (1); + + } elsif ($line->value =~ /^[012]$/) { + $self->conflict ($conflict_modes[$line->value]); + $line->parsed (1); + + } else { + $line->error ($line->value, ': invalid value'); + } + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->parse_cfg_project (\@cfg_lines); +# +# DESCRIPTION +# This method parses the project settings in the @cfg_lines. +# ------------------------------------------------------------------------------ + +sub parse_cfg_project { + my ($self, $cfg_lines) = @_; + + # Flag to indicate that a declared branch revision must match with its changed + # revision + # ---------------------------------------------------------------------------- + for my $line (grep {$_->slabel_starts_with_cfg ('REVMATCH')} @$cfg_lines) { + next if ($line->slabel_fields) > 1; + $self->setting ([qw/EXT_REVMATCH/], $line->bvalue); + $line->parsed (1); + } + + # Repository, revision and source directories + # ---------------------------------------------------------------------------- + for my $name (qw/repos revision dirs expdirs/) { + my @lines = grep { + $_->slabel_starts_with_cfg (uc ($name)) or + $name eq 'revision' and $_->slabel_starts_with_cfg ('VERSION'); + } @$cfg_lines; + for my $line (@lines) { + my @names = $line->slabel_fields; + shift @names; + + # Detemine package and tag + my $tag = pop @names; + my $pckroot = $names[0]; + my $pck = join ($Fcm::Config::DELIMITER, @names); + + # Check that $tag and $pckroot are defined + next unless $tag and $pckroot; + + # Check if branch already exists. + # If so, set $branch to point to existing branch + my $branch = undef; + for (@{ $self->branches }) { + next unless $_->package eq $pckroot and $_->tag eq $tag; + + $branch = $_; + last; + } + + # Otherwise, create a new branch + if (not $branch) { + $branch = Fcm::ReposBranch->new (PACKAGE => $pckroot, TAG => $tag,); + + push @{ $self->branches }, $branch; + } + + if ($name eq 'repos' or $name eq 'revision') { + # Branch location or revision + $branch->$name ($line->value); + + } else { # $name eq 'dirs' or $name eq 'expdirs' + # Source directory or expandable source directory + if ($pck eq $pckroot and $line->value !~ m#^/#) { + # Sub-package name not set and source directory quoted as a relative + # path, determine package name from path name + $pck = join ( + $Fcm::Config::DELIMITER, + ($pckroot, File::Spec->splitdir ($line->value)), + ); + } + + # A "/" is equivalent to the top (empty) package + my $value = ($line->value =~ m#^/+$#) ? '' : $line->value; + $branch->$name ($pck, $value); + } + + $line->parsed (1); + } + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_cfg (); +# +# DESCRIPTION +# This method expands the settings of the extract configuration. +# ------------------------------------------------------------------------------ + +sub expand_cfg { + my $self = shift; + + my $rc = 1; + for my $use (@{ $self->inherit }) { + $rc = $use->expand_cfg if $rc; + } + + return $rc unless $rc; + + # Establish a set of source directories from the "base repository" + my %base_branches = (); + + # Inherit "base" set of source directories from re-used extracts + for my $use (@{ $self->inherit }) { + my @branches = @{ $use->branches }; + + for my $branch (@branches) { + my $package = $branch->package; + $base_branches{$package} = $branch unless exists $base_branches{$package}; + } + } + + for my $branch (@{ $self->branches }) { + # Expand URL keywords if necessary + if ($branch->repos) { + my $repos = Fcm::Util::tidy_url(Fcm::Keyword::expand($branch->repos())); + $branch->repos ($repos) if $repos ne $branch->repos; + } + + # Check that repository type and revision are set + if ($branch->repos and &is_url ($branch->repos)) { + $branch->type ('svn') unless $branch->type; + $branch->revision ('head') unless $branch->revision; + + } else { + $branch->type ('user') unless $branch->type; + $branch->revision ('user') unless $branch->revision; + } + + $rc = $branch->expand_revision if $rc; # Get revision number from keywords + $rc = $branch->expand_path if $rc; # Expand relative path to full path + $rc = $branch->expand_all if $rc; # Search sub-directories + last unless $rc; + + my $package = $branch->package; + + if (exists $base_branches{$package}) { + # A base branch for this package exists + + # If current branch has no source directory, use the set provided by the + # base branch + my %dirs = %{ $branch->dirs }; + $branch->add_base_dirs ($base_branches{$package}) unless keys %dirs; + + } else { + # This package does not yet have a base branch, set this branch as base + $base_branches{$package} = $branch; + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->create_dir_stack (); +# +# DESCRIPTION +# This method creates a hash of source directories to be processed. If the +# flag INHERITED is set to true, the source directories are assumed processed +# and extracted. +# ------------------------------------------------------------------------------ + +sub create_dir_stack { + my $self = shift; + my %args = @_; + + # Inherit from USE ext cfg + for my $use (@{ $self->inherit }) { + $use->create_dir_stack () or return 0; + my %use_srcdirs = %{ $use->srcdirs }; + + while (my ($key, $value) = each %use_srcdirs) { + $self->srcdirs ($key, $value); + + # Re-set destination to current destination + my @path = split (/$Fcm::Config::DELIMITER/, $key); + $self->srcdirs ($key)->{DEST} = File::Spec->catfile ( + $self->dest->srcdir, @path, + ); + } + } + + # Build stack from current ext cfg + for my $branch (@{ $self->branches }) { + my %branch_dirs = %{ $branch->dirs }; + + for my $dir (keys %branch_dirs) { + # Check whether source directory is already in the list + if (not $self->srcdirs ($dir)) { # if not, create it + $self->srcdirs ($dir, { + DEST => File::Spec->catfile ( + $self->dest->srcdir, split (/$Fcm::Config::DELIMITER/, $dir) + ), + STACK => [], + FILES => {}, + }); + } + + my $stack = $self->srcdirs ($dir)->{STACK}; # copy reference + + # Create a new layer in the input stack + my $layer = Fcm::SrcDirLayer->new ( + NAME => $dir, + PACKAGE => $branch->package, + TAG => $branch->tag, + LOCATION => $branch->dirs ($dir), + REPOSROOT => $branch->repos, + REVISION => $branch->revision, + TYPE => $branch->type, + EXTRACTED => @{ $self->inherited } + ? $self->srcdirs ($dir)->{DEST} : undef, + ); + + # Check whether layer is already in the stack + my $exist = grep { + $_->location eq $layer->location and $_->revision eq $layer->revision; + } @{ $stack }; + + if (not $exist) { + # If not already exist, put layer into stack + + # Note: user stack always comes last + if (! $layer->user and exists $stack->[-1] and $stack->[-1]->user) { + my $lastlayer = pop @{ $stack }; + push @{ $stack }, $layer; + $layer = $lastlayer; + } + + push @{ $stack }, $layer; + + } elsif ($layer->user) { + + # User layer already exists, overwrite it + $stack->[-1] = $layer; + + } + } + } + + # Use the cache to sort the source directory layer hash + return $self->compare_setting (METHOD_LIST => ['sort_dir_stack']); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, \@new_lines) = $self->sort_dir_stack ($old_lines); +# +# DESCRIPTION +# This method sorts thesource directories hash to be processed. +# ------------------------------------------------------------------------------ + +sub sort_dir_stack { + my ($self, $old_lines) = @_; + + my $rc = 0; + + my %old = (); + if ($old_lines) { + for my $line (@$old_lines) { + $old{$line->label} = $line->value; + } + } + + my %new; + + # Compare each layer to base layer, discard unnecessary layers + DIR: for my $srcdir (keys %{ $self->srcdirs }) { + my @stack = (); + + while (my $layer = shift @{ $self->srcdirs ($srcdir)->{STACK} }) { + if ($layer->user) { + # Local file system branch, check that the declared location exists + if (-d $layer->location) { + # Local file system branch always takes precedence + push @stack, $layer; + + } else { + w_report 'ERROR: ', $layer->location, ': declared source directory ', + 'does not exists '; + $rc = undef; + last DIR; + } + + } else { + my $key = join ($Fcm::Config::DELIMITER, ( + $srcdir, $layer->location, $layer->revision + )); + + unless ($layer->extracted and $layer->commit) { + # See if commit revision information is cached + if (keys %old and exists $old{$key}) { + $layer->commit ($old{$key}); + + } else { + $layer->get_commit; + $rc = 1; + } + + # Check source directory for commit revision, if necessary + if (not $layer->commit) { + w_report 'Error: cannot determine the last changed revision of ', + $layer->location; + $rc = undef; + last DIR; + } + + # Set cache directory for layer + my $tag_ver = $layer->tag . '__' . $layer->commit; + $layer->cachedir (File::Spec->catfile ( + $self->dest->cachedir, + split (/$Fcm::Config::DELIMITER/, $srcdir), + $tag_ver, + )); + } + + # New line in cache config file + $new{$key} = $layer->commit; + + # Push this layer in the stack: + # 1. it has a different revision compared to the top layer + # 2. it is the top layer (base line code) + if (@stack > 0) { + push @stack, $layer if $layer->commit != $stack[0]->commit; + + } else { + push @stack, $layer; + } + + } + } + + $self->srcdirs ($srcdir)->{STACK} = \@stack; + } + + # Write "commit cache" file + my @new_lines; + if (defined ($rc)) { + for my $key (sort keys %new) { + push @new_lines, Fcm::CfgLine->new (label => $key, value => $new{$key}); + } + } + + return ($rc, \@new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->extract_src (); +# +# DESCRIPTION +# This internal method performs the extract of the source directories and +# files if necessary. +# ------------------------------------------------------------------------------ + +sub extract_src { + my $self = shift; + my $rc = 1; + + # Ensure destinations exist and are directories + for my $srcdir (values %{ $self->srcdirs }) { + last if not $rc; + if (-f $srcdir->{DEST}) { + w_report $srcdir->{DEST}, + ': destination exists and is not a directory, abort.'; + $rc = 0; + } + } + + # Retrieve previous/record current extract configuration for each file. + $rc = $self->compare_setting ( + CACHEBASE => $self->setting ('CACHE_FILE_SRC'), + METHOD_LIST => ['compare_setting_srcfiles'], + ) if $rc; + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, \@new_lines) = $self->compare_setting_srcfiles ($old_lines); +# +# DESCRIPTION +# For each file to be extracted, this method creates an instance of an +# Fcm::ExtractFile object. It then compares its file's sources to determine +# if they have changed. If so, it will allow the Fcm::ExtractFile to +# "re-extract" the file to the destination. Otherwise, it will set +# Fcm::ExtractFile->dest_status to a null string to denote an "unchanged" +# dest_status. +# +# SEE ALSO +# Fcm::ConfigSystem->compare_setting. +# ------------------------------------------------------------------------------ + +sub compare_setting_srcfiles { + my ($self, $old_lines) = @_; + my $rc = 1; + + # Retrieve previous extract configuration for each file + # ---------------------------------------------------------------------------- + my %old = (); + if ($old_lines) { + for my $line (@$old_lines) { + $old{$line->label} = $line->value; + } + } + + # Build up a sequence using a Fcm::ExtractFile object for each file + # ---------------------------------------------------------------------------- + for my $srcdir (values %{ $self->srcdirs }) { + my %pkgnames0; # (to be) list of package names in the base layer + for my $i (0 .. @{ $srcdir->{STACK} } - 1) { + my $layer = $srcdir->{STACK}->[$i]; + # Update the cache for each layer of the stack if necessary + $layer->update_cache unless $layer->extracted or -d $layer->localdir; + + # Get list of files in the cache or local directory + my %pkgnames; + for my $file (($layer->get_files)) { + my $pkgname = join ( + '/', split (/$Fcm::Config::DELIMITER/, $layer->name), $file + ); + $pkgnames0{$pkgname} = 1 if $i == 0; # store package name in base layer + $pkgnames{$pkgname} = 1; # store package name in the current layer + if (not $self->files ($pkgname)) { + $self->files ($pkgname, Fcm::ExtractFile->new ( + conflict => $self->conflict, + dest => $self->dest->srcpath, + pkgname => $pkgname, + )); + + # Base is empty + $self->files ($pkgname)->src->[0] = Fcm::ExtractSrc->new ( + id => $layer->tag, + pkgname => $pkgname, + ) if $i > 0; + } + my $cache = File::Spec->catfile ($layer->localdir, $file); + push @{ $self->files ($pkgname)->src }, Fcm::ExtractSrc->new ( + cache => $cache, + id => $layer->tag, + pkgname => $pkgname, + rev => ($layer->user ? (stat ($cache))[9] : $layer->commit), + uri => join ('/', $layer->location, $file), + ); + } + + # List of removed files in this layer (relative to base layer) + if ($i > 0) { + for my $pkgname (keys %pkgnames0) { + push @{ $self->files ($pkgname)->src }, Fcm::ExtractSrc->new ( + id => $layer->tag, + pkgname => $pkgname, + ) if not exists $pkgnames{$pkgname} + } + } + } + } + + # Compare with old settings + # ---------------------------------------------------------------------------- + my %new = (); + for my $key (sort keys %{ $self->files }) { + # Set up value for cache + my @sources = (); + for my $src (@{ $self->files ($key)->src }) { + push @sources, (defined ($src->uri) ? ($src->uri . '@' . $src->rev) : ''); + } + + my $value = join ($Fcm::Config::DELIMITER, @sources); + + # Set Fcm::ExtractFile->dest_status to "unchanged" if value is unchanged + $self->files ($key)->dest_status ('') + if exists $old{$key} and $old{$key} eq $value; + + # Write current settings + $new{$key} = $value; + } + + # Delete those that exist in previous extract but not in current + # ---------------------------------------------------------------------------- + for my $key (sort keys %old) { + next if exists $new{$key}; + $self->files ($key, Fcm::ExtractFile->new ( + dest => $self->dest->srcpath, + pkgname => $key, + )); + } + + # Extract each file, if necessary + # ---------------------------------------------------------------------------- + for my $key (sort keys %{ $self->files }) { + $rc = $self->files ($key)->run if defined ($rc); + last if not defined ($rc); + } + + # Report status + # ---------------------------------------------------------------------------- + if (defined ($rc) and $self->verbose) { + my %src_status_count = (); + my %dest_status_count = (); + for my $key (sort keys %{ $self->files }) { + # Report changes in destination in verbose 1 or above + my $dest_status = $self->files ($key)->dest_status; + my $src_status = $self->files ($key)->src_status; + next unless $self->verbose and $dest_status; + + if ($dest_status and $dest_status ne '?') { + if (exists $dest_status_count{$dest_status}) { + $dest_status_count{$dest_status}++; + + } else { + $dest_status_count{$dest_status} = 1; + } + } + + if ($src_status and $src_status ne '?') { + if (exists $src_status_count{$src_status}) { + $src_status_count{$src_status}++; + + } else { + $src_status_count{$src_status} = 1; + } + } + + # Destination status in column 1, source status in column 2 + if ($self->verbose > 1) { + my @srcs = @{$self->files ($key)->src_actual}; + print ($dest_status ? $dest_status : ' '); + print ($src_status ? $src_status : ' '); + print ' ' x 5, $key; + print ' (', join (', ', map {$_->id} @srcs), ')' if @srcs; + print "\n"; + } + } + + # Report number of files in each dest_status category + if (%dest_status_count) { + print 'Column 1: ' if $self->verbose > 1; + print 'Destination status summary:', "\n"; + for my $key (sort keys %Fcm::ExtractFile::DEST_STATUS_CODE) { + next unless $key; + next if not exists ($dest_status_count{$key}); + print ' No of files '; + print '[', $key, '] ' if $self->verbose > 1; + print $Fcm::ExtractFile::DEST_STATUS_CODE{$key}, ': ', + $dest_status_count{$key}, "\n"; + } + } + + # Report number of files in each dest_status category + if (%src_status_count) { + print 'Column 2: ' if $self->verbose > 1; + print 'Source status summary:', "\n"; + for my $key (sort keys %Fcm::ExtractFile::SRC_STATUS_CODE) { + next unless $key; + next if not exists ($src_status_count{$key}); + print ' No of files '; + print '[', $key, '] ' if $self->verbose > 1; + print $Fcm::ExtractFile::SRC_STATUS_CODE{$key}, ': ', + $src_status_count{$key}, "\n"; + } + } + } + + # Record configuration of current extract for each file + # ---------------------------------------------------------------------------- + my @new_lines; + if (defined ($rc)) { + for my $key (sort keys %new) { + push @new_lines, Fcm::CfgLine->new (label => $key, value => $new{$key}); + } + } + + return ($rc, \@new_lines); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @array = $self->sort_bdeclare (); +# +# DESCRIPTION +# This method returns sorted build declarations, filtering out repeated +# entries, where possible. +# ------------------------------------------------------------------------------ + +sub sort_bdeclare { + my $self = shift; + + # Get list of build configuration labels that can be declared multiple times + my %cfg_keyword = map { + ($self->cfglabel ($_), 1) + } split (/$Fcm::Config::DELIMITER_LIST/, $self->setting ('CFG_KEYWORD')); + + my @bdeclares = (); + for my $d (reverse @{ $self->bdeclare }) { + # Reconstruct array from bottom up + # * always add declarations that can be declared multiple times + # * otherwise add only if it is declared below + unshift @bdeclares, $d + if exists $cfg_keyword{uc (($d->slabel_fields)[0])} or + not grep {$_->slabel eq $d->slabel} @bdeclares; + } + + return (sort {$a->slabel cmp $b->slabel} @bdeclares); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines (); +# +# DESCRIPTION +# See description of Fcm::ConfigSystem->to_cfglines for further information. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self) = @_; + + return ( + Fcm::ConfigSystem::to_cfglines($self), + + $self->rdest->to_cfglines (), + Fcm::CfgLine->new (), + + @{ $self->bdeclare } ? ( + Fcm::CfgLine::comment_block ('Build declarations'), + map { + Fcm::CfgLine->new (label => $_->label, value => $_->value) + } ($self->sort_bdeclare), + Fcm::CfgLine->new (), + ) : (), + + Fcm::CfgLine::comment_block ('Project and branches'), + (map {($_->to_cfglines ())} @{ $self->branches }), + + ($self->conflict ne 'merge') ? ( + Fcm::CfgLine->new ( + label => $self->cfglabel ('CONFLICT'), value => $self->conflict, + ), + Fcm::CfgLine->new (), + ) : (), + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines_bld (); +# +# DESCRIPTION +# Returns a list of configuration lines of the current extract suitable for +# feeding into the build system. +# ------------------------------------------------------------------------------ + +sub to_cfglines_bld { + my ($self) = @_; + + my $dest = $self->rdest->rootdir ? 'rdest' : 'dest'; + my $root = File::Spec->catfile ('$HERE', '..'); + + my @inherits; + my @no_inherits; + if (@{ $self->inherit }) { + # List of inherited builds + for (@{ $self->inherit }) { + push @inherits, Fcm::CfgLine->new ( + label => $self->cfglabel ('USE'), value => $_->$dest->rootdir + ); + } + + # List of files that should not be inherited + for my $key (sort keys %{ $self->files }) { + next unless $self->files ($key)->dest_status eq 'd'; + my $label = join ('::', ( + $self->cfglabel ('INHERIT'), + $self->cfglabel ('FILE'), + split (m#/#, $self->files ($key)->pkgname), + )); + push @no_inherits, Fcm::CfgLine->new (label => $label, value => 'false'); + } + } + + return ( + Fcm::CfgLine::comment_block ('File header'), + (map + {my ($lbl, $val) = @{$_}; Fcm::CfgLine->new(label => $lbl, value => $val)} + ( + [$self->cfglabel('CFGFILE') . $Fcm::Config::DELIMITER . 'TYPE' , 'bld'], + [$self->cfglabel('CFGFILE') . $Fcm::Config::DELIMITER . 'VERSION', '1.0'], + [], + ) + ), + + @{ $self->inherit } ? ( + @inherits, + @no_inherits, + Fcm::CfgLine->new (), + ) : (), + + Fcm::CfgLine::comment_block ('Destination'), + Fcm::CfgLine->new (label => $self->cfglabel ('DEST'), value => $root), + Fcm::CfgLine->new (), + + @{ $self->bdeclare } ? ( + Fcm::CfgLine::comment_block ('Build declarations'), + map { + Fcm::CfgLine->new (label => $_->slabel, value => $_->value) + } ($self->sort_bdeclare), + Fcm::CfgLine->new (), + ) : (), + ); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->write_cfg (); +# +# DESCRIPTION +# This method writes the configuration file at the end of the run. It calls +# $self->write_cfg_system ($cfg) to write any system specific settings. +# ------------------------------------------------------------------------------ + +sub write_cfg { + my $self = shift; + + my $cfg = Fcm::CfgFile->new (TYPE => $self->type); + $cfg->lines ([$self->to_cfglines()]); + $cfg->print_cfg ($self->dest->extcfg); + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $self->write_cfg_bld (); +# +# DESCRIPTION +# This internal method writes the build configuration file. +# ------------------------------------------------------------------------------ + +sub write_cfg_bld { + my $self = shift; + + my $cfg = Fcm::CfgFile->new (TYPE => 'bld'); + $cfg->lines ([$self->to_cfglines_bld()]); + $cfg->print_cfg ($self->dest->bldcfg); + + return 1; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractConfigComparator.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractConfigComparator.pm new file mode 100644 index 0000000..c74ea59 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractConfigComparator.pm @@ -0,0 +1,358 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +################################################################################ +# A generic reporter of the comparator's result +{ + package Reporter; + + ############################################################################ + # Class method: Constructor + sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); + } + + ############################################################################ + # Class method: Factory for Reporter object + sub get_reporter { + my ($self, $comparator) = @_; + my $class = defined($comparator->get_wiki()) ? 'WikiReporter' + : 'TextReporter' + ; + return $class->new(); + } + + ############################################################################ + # Reports the results + sub report { + my ($self, $comparator) = @_; + if (keys(%{$comparator->get_log_of()})) { + print("Revisions at which extract declarations are modified:\n\n"); + } + $self->report_impl($comparator); + } + + ############################################################################ + # Does the actual reporting + sub report_impl { + my ($self, $comparator) = @_; + } +} + +################################################################################ +# Reports the comparator's result in Trac wiki format +{ + package WikiReporter; + our @ISA = qw{Reporter}; + + use Fcm::CmUrl; + use Fcm::Keyword; + use Fcm::Util qw{tidy_url}; + + ############################################################################ + # Reports the comparator's result + sub report_impl { + my ($self, $comparator) = @_; + # Output in wiki format + my $wiki_url = Fcm::CmUrl->new( + URL => tidy_url(Fcm::Keyword::expand($comparator->get_wiki())) + ); + my $base_trac + = $comparator->get_wiki() + ? Fcm::Keyword::get_browser_url($wiki_url->project_url()) + : $wiki_url; + if (!$base_trac) { + $base_trac = $wiki_url; + } + + for my $key (sort keys(%{$comparator->get_log_of()})) { + my $branch_trac = Fcm::Keyword::get_browser_url($key); + $branch_trac =~ s{\A $base_trac (?:/*|\z)}{source:}xms; + print("[$branch_trac]:\n"); + my %branch_of = %{$comparator->get_log_of()->{$key}}; + for my $rev (sort {$b <=> $a} keys(%branch_of)) { + print( + $branch_of{$rev}->display_svnlog($rev, $base_trac), "\n", + ); + } + print("\n"); + } + } +} + +################################################################################ +# Reports the comparator's result in simple text format +{ + package TextReporter; + our @ISA = qw{Reporter}; + + use Fcm::Config; + + my $SEPARATOR = q{-} x 80 . "\n"; + + ############################################################################ + # Reports the comparator's result + sub report_impl { + my ($self, $comparator) = @_; + for my $key (sort keys(%{$comparator->get_log_of()})) { + # Output in plain text format + print $key, ':', "\n"; + my %branch_of = %{$comparator->get_log_of()->{$key}}; + if (Fcm::Config->instance()->verbose() > 1) { + for my $rev (sort {$b <=> $a} keys(%branch_of)) { + print( + $SEPARATOR, $branch_of{$rev}->display_svnlog($rev), "\n" + ); + } + } + else { + print(join(q{ }, sort {$b <=> $a} keys(%branch_of)), "\n"); + } + print $SEPARATOR, "\n"; + } + } +} + +package Fcm::ExtractConfigComparator; + +use Fcm::CmUrl; +use Fcm::Extract; + +################################################################################ +# Class method: Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns an array containing the 2 configuration files to compare +sub get_files { + my ($self) = @_; + return (wantarray() ? @{$self->{files}} : $self->{files}); +} + +################################################################################ +# Returns the wiki link on wiki mode +sub get_wiki { + my ($self) = @_; + return $self->{wiki}; +} + +################################################################################ +# Returns the result log +sub get_log_of { + my ($self) = @_; + return (wantarray() ? %{$self->{log_of}} : $self->{log_of}); +} + +################################################################################ +# Invokes the comparator +sub invoke { + my ($self) = @_; + + # Reads the extract configurations + my (@cfg, $rc); + for my $i (0 .. 1) { + $cfg[$i] = Fcm::Extract->new(); + $cfg[$i]->cfg()->src($self->get_files()->[$i]); + $cfg[$i]->parse_cfg(); + $rc = $cfg[$i]->expand_cfg(); + if (!$rc) { + e_report(); + } + } + + # Get list of URLs + # -------------------------------------------------------------------------- + my @urls = (); + for my $i (0 .. 1) { + # List of branches in each extract configuration file + my @branches = @{$cfg[$i]->branches()}; + BRANCH: + for my $branch (@branches) { + # Ignore declarations of local directories + if ($branch->type() eq 'user') { + next BRANCH; + } + + # List of SRC declarations in each branch + my %dirs = %{$branch->dirs()}; + + for my $dir (values(%dirs)) { + # Set up a new instance of Fcm::CmUrl object for each SRC + my $cm_url = Fcm::CmUrl->new ( + URL => $dir . ( + $branch->revision() ? '@' . $branch->revision() : q{} + ), + ); + + $urls[$i]{$cm_url->branch_url()}{$dir} = $cm_url; + } + } + } + + # Compare + # -------------------------------------------------------------------------- + $self->{log_of} = {}; + for my $i (0 .. 1) { + # Compare the first file with the second one and then vice versa + my $j = ($i == 0) ? 1 : 0; + + for my $branch (sort keys(%{$urls[$i]})) { + if (exists($urls[$j]{$branch})) { + # Same REPOS declarations in both files + DIR: + for my $dir (sort keys(%{$urls[$i]{$branch}})) { + if (exists($urls[$j]{$branch}{$dir})) { + if ($i == 1) { + next DIR; + } + + my $this_url = $urls[$i]{$branch}{$dir}; + my $that_url = $urls[$j]{$branch}{$dir}; + + # Compare their last changed revisions + my $this_rev + = $this_url->svninfo(FLAG => 'Last Changed Rev'); + my $that_rev + = $that_url->svninfo(FLAG => 'Last Changed Rev'); + + # Make sure last changed revisions differ + if ($this_rev eq $that_rev) { + next DIR; + } + + # Not interested in the log before the minimum revision + my $min_rev + = $this_url->pegrev() > $that_url->pegrev() + ? $that_url->pegrev() : $this_url->pegrev(); + + $this_rev = $min_rev if $this_rev < $min_rev; + $that_rev = $min_rev if $that_rev < $min_rev; + + # Get list of changed revisions using the commit log + my $u = ($this_rev > $that_rev) ? $this_url : $that_url; + my %revs = $u->svnlog(REV => [$this_rev, $that_rev]); + + REV: + for my $rev (keys %revs) { + # Check if revision is already in the list + if ( + exists($self->{log_of}{$branch}{$rev}) + || $rev == $min_rev + ) { + next REV; + } + + # Get list of changed paths. Accept this revision + # only if it contains changes in the current branch + my %paths = %{$revs{$rev}{paths}}; + + PATH: + for my $path (keys(%paths)) { + my $change_url + = Fcm::CmUrl->new(URL => $u->root() . $path); + + if ($change_url->branch() eq $u->branch()) { + $self->{log_of}{$branch}{$rev} = $u; + last PATH; + } + } + } + } + else { + $self->_report_added( + $urls[$i]{$branch}{$dir}->url_peg(), $i, $j); + } + } + } + else { + $self->_report_added($branch, $i, $j); + } + } + } + + my $reporter = Reporter->get_reporter($self); + $reporter->report($self); + return $rc; +} + +################################################################################ +# Reports added/deleted declaration +sub _report_added { + my ($self, $branch, $i, $j) = @_; + printf( + "%s:\n in : %s\n not in: %s\n\n", + $branch, $self->get_files()->[$i], $self->get_files()->[$j], + ); +} + +1; +__END__ + +=head1 NAME + +Fcm::ExtractConfigComparator + +=head1 SYNOPSIS + + use Fcm::ExtractConfigComparator; + my $comparator = Fcm::ExtractConfigComparator->new({files => \@files}); + $comparator->invoke(); + +=head1 DESCRIPTION + +An object of this class represents a comparator of FCM extract configuration. +It is used to compare the VC branch declarations in 2 FCM extract configuration +files. + +=head1 METHODS + +=over 4 + +=item C \@files, wiki =E $wiki})> + +Constructor. + +=item get_files() + +Returns an array containing the 2 configuration files to compare. + +=item get_wiki() + +Returns the wiki link on wiki mode. + +=item invoke() + +Invokes the comparator. + +=back + +=head1 TO DO + +More documentation. + +Improve the parser for extract configuration. + +Separate the comparator with the reporters. + +Add reporter to display HTML. + +More unit tests. + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractFile.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractFile.pm new file mode 100644 index 0000000..7221812 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractFile.pm @@ -0,0 +1,410 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ExtractFile +# +# DESCRIPTION +# Select/combine a file in different branches and extract it to destination. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use warnings; +use strict; + +package Fcm::ExtractFile; +use base qw{Fcm::Base}; + +use Fcm::Util qw{run_command w_report}; +use File::Basename qw{dirname}; +use File::Compare qw{compare}; +use File::Copy qw{copy}; +use File::Path qw{mkpath}; +use File::Spec; +use File::Temp qw(tempfile); + +# List of property methods for this class +my @scalar_properties = ( + 'conflict', # conflict mode + 'dest', # search path to destination file + 'dest_status', # destination status, see below + 'pkgname', # package name of this file + 'src', # list of Fcm::ExtractSrc, specified for this file + 'src_actual', # list of Fcm::ExtractSrc, actually used by this file + 'src_status', # source status, see below +); + +# Status code definition for $self->dest_status +our %DEST_STATUS_CODE = ( + '' => 'unchanged', + 'M' => 'modified', + 'A' => 'added', + 'a' => 'added, overridding inherited', + 'D' => 'deleted', + 'd' => 'deleted, overridding inherited', + '?' => 'irrelevant', +); + +# Status code definition for $self->src_status +our %SRC_STATUS_CODE = ( + 'A' => 'added by a branch', + 'B' => 'from the base', + 'D' => 'deleted by a branch', + 'M' => 'modified by a branch', + 'G' => 'merged from 2+ branches', + 'O' => 'overridden by a branch', + '?' => 'irrelevant', +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ExtractFile->new (); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ExtractFile class. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{$_} ? $args{$_} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'conflict') { + $self->{$name} = 'merge'; # default to "merge" mode + + } elsif ($name eq 'dest' or $name eq 'src' or $name eq 'src_actual') { + $self->{$name} = []; # default to an empty list + } + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->run(); +# +# DESCRIPTION +# This method runs only if $self->dest_status is not defined. It updates the +# destination according to the source in the list and the conflict mode +# setting. It updates the file in $self->dest as appropriate and sets +# $self->dest_status. (See above.) This method returns true on success. +# ------------------------------------------------------------------------------ + +sub run { + my ($self) = @_; + my $rc = 1; + + if (not defined ($self->dest_status)) { + # Assume file unchanged + $self->dest_status (''); + + if (@{ $self->src }) { + my $used; + # Determine or set up a file for comparing with the destination + ($rc, $used) = $self->run_get_used(); + + # Attempt to compare the destination with $used. Update on change. + if ($rc) { + $rc = defined ($used) ? $self->run_update($used) : $self->run_delete(); + } + + } else { + # No source, delete file in destination + $self->src_status ('?'); + $rc = $self->run_delete(); + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->run_delete(); +# +# DESCRIPTION +# This method is part of run(). It detects this file in the destination path. +# If this file is in the current destination, it attempts to delete it and +# sets the dest_status to "D". If this file is in an inherited destination, +# it sets the dest_status to "d". +# ------------------------------------------------------------------------------ + +sub run_delete { + my ($self) = @_; + + my $rc = 1; + + $self->dest_status ('?'); + for my $i (0 .. @{ $self->dest } - 1) { + my $dest = File::Spec->catfile ($self->dest->[$i], $self->pkgname); + next unless -f $dest; + if ($i == 0) { + $rc = unlink $dest; + $self->dest_status ('D'); + + } else { + $self->dest_status ('d'); + last; + } + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $used) = $obj->run_get_used(); +# +# DESCRIPTION +# This method is part of run(). It attempts to work out or set up the $used +# file. ($used is undef if it is not defined in a branch for this file.) +# ------------------------------------------------------------------------------ + +sub run_get_used { + my ($self) = @_; + my $rc = 1; + my $used; + + my @sources = ($self->src->[0]); + my $src_status = 'B'; + if (defined ($self->src->[0]->cache)) { + # File exists in base branch + for my $i (1 .. @{ $self->src } - 1) { + if (defined ($self->src->[$i]->cache)) { + # Detect changes in this file between base branch and branch $i + push @sources, $self->src->[$i] + if &compare ($self->src->[0]->cache, $self->src->[$i]->cache); + + } else { + # File deleted in branch $i + @sources = ($self->src->[$i]); + last unless $self->conflict eq 'override'; + } + } + + if ($rc) { + if (@sources > 2) { + if ($self->conflict eq 'fail') { + # On conflict, fail in fail mode + w_report 'ERROR: ', $self->pkgname, + ': modified in 2+ branches in fail conflict mode.'; + $rc = undef; + + } elsif ($self->conflict eq 'override') { + $used = $sources[-1]->cache; + $src_status = 'O'; + + } else { + # On conflict, attempt to merge in merge mode + ($rc, $used) = $self->run_get_used_by_merge (@sources); + $src_status = 'G' if $rc; + } + + } else { + # 0 or 1 change, use last source + if (defined $sources[-1]->cache) { + $used = $sources[-1]->cache; + $src_status = 'M' if @sources > 1; + + } else { + $src_status = 'D'; + } + } + } + + } else { + # File does not exist in base branch + @sources = ($self->src->[-1]); + $used = $self->src->[1]->cache; + $src_status = (defined ($used) ? 'A' : 'D'); + if ($self->conflict ne 'override' and defined ($used)) { + for my $i (1 - @{ $self->src } .. -2) { + # Allow this only if files are the same in all branches + my $file = $self->src->[$i]->cache; + if ((not defined ($file)) or &compare ($used, $file)) { + w_report 'ERROR: ', $self->pkgname, ': cannot merge:', + ' not found in base branch,', + ' but differs in subsequent branches.'; + $rc = undef; + last; + + } else { + unshift @sources, $self->src->[$i]; + } + } + } + } + + $self->src_status ($src_status); + $self->src_actual (\@sources); + + return ($rc, $used); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# ($rc, $used) = $obj->run_get_used_by_merge(@soruces); +# +# DESCRIPTION +# This method is part of run_get_used(). It attempts to merge the files in +# @sources and return a temporary file $used. @sources should be an array of +# Fcm::ExtractSrc objects. On success, $rc will be set to true. +# ------------------------------------------------------------------------------ + +sub run_get_used_by_merge { + my ($self, @sources) = @_; + my $rc = 1; + + # Get temporary file + my ($fh, $used) = &tempfile ('fcm.ext.merge.XXXXXX', UNLINK => 1); + close $fh or die $used, ': cannot close'; + + for my $i (2 .. @sources - 1) { + # Invoke the diff3 command to merge + my $mine = ($i == 2 ? $sources[1]->cache : $used); + my $older = $sources[0]->cache; + my $yours = $sources[$i]->cache; + my @command = ( + $self->setting (qw/TOOL DIFF3/), + split (/\s+/, $self->setting (qw/TOOL DIFF3FLAGS/)), + $mine, $older, $yours, + ); + my $code; + my @out = &run_command ( + \@command, + METHOD => 'qx', + ERROR => 'ignore', + PRINT => $self->verbose > 1, + RC => \$code, + TIME => $self->verbose > 2, + ); + + if ($code) { + # Failure, report and return + my $m = ($code == 1) + ? 'cannot resolve conflicts:' + : $self->setting (qw/TOOL DIFF3/) . 'command failed'; + w_report 'ERROR: ', $self->pkgname, ': merge - ', $m; + if ($code == 1 and $self->verbose) { + for (0 .. $i) { + my $src = $sources[$_]->uri eq $sources[$_]->cache + ? $sources[$_]->cache + : ($sources[$_]->uri . '@' . $sources[$_]->rev); + w_report ' source[', $_, ']=', $src; + } + + for (0 .. $i) { + w_report ' cache', $_, '=', $sources[$_]->cache; + } + + w_report @out if $self->verbose > 2; + } + $rc = undef; + last; + + } else { + # Success, write result to temporary file + open FILE, '>', $used or die $used, ': cannot open (', $!, ')'; + print FILE @out; + close FILE or die $used, ': cannot close (', $!, ')'; + + # File permission, use most permissive combination of $mine and $yours + my $perm = ((stat($mine))[2] & 07777) | ((stat($yours))[2] & 07777); + chmod ($perm, $used); + } + } + + return ($rc, $used); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->run_update($used_file); +# +# DESCRIPTION +# This method is part of run(). It compares the $used_file with the one in +# the destination. If the file does not exist in the destination or if its +# content is out of date, the destination is updated with the content in the +# $used_file. Returns true on success. +# ------------------------------------------------------------------------------ + +sub run_update { + my ($self, $used_file) = @_; + my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1); + + # Compare with the previous version if it exists + DEST: + for my $i (0 .. @{$self->dest()} - 1) { + my $prev_file = File::Spec->catfile($self->dest()->[$i], $self->pkgname()); + if (-f $prev_file) { + $is_in_prev = $i; + $is_diff = compare($used_file, $prev_file); + $is_diff_in_perms = (stat($used_file))[2] != (stat($prev_file))[2]; + last DEST; + } + } + if (!$is_diff && !$is_diff_in_perms) { + return $rc; + } + + # Update destination + my $dest_file = File::Spec->catfile($self->dest()->[0], $self->pkgname()); + if ($is_diff) { + my $dir = dirname($dest_file); + if (!-d $dir) { + mkpath($dir); + } + $rc = copy($used_file, $dest_file); + } + $rc &&= chmod((stat($used_file))[2] & oct(7777), $dest_file); + if ($rc) { + $self->dest_status( + $is_in_prev ? 'a' + : defined($is_in_prev) ? 'M' + : 'A' + ); + } + return $rc; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractSrc.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractSrc.pm new file mode 100644 index 0000000..e9b92fa --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ExtractSrc.pm @@ -0,0 +1,87 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ExtractSrc +# +# DESCRIPTION +# This class is used by the extract system to define the functionalities of a +# source file (or directory) in a branch. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::ExtractSrc; +@ISA = qw(Fcm::Base); + +# Standard pragma +use warnings; +use strict; + +# FCM component modules +use Fcm::Base; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'cache', # location of the cache of this file in the current extract + 'id', # short ID of the branch where this file is from + 'ignore', # if set to true, ignore this file from this source + 'pkgname', # package name of this file + 'rev', # last changed revision/timestamp of this file + 'uri', # URL/source path of this file +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ExtractSrc->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ExtractSrc class. See +# @scalar_properties above for allowed list of properties in the constructor. +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{$_} ? $args{$_} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive.pm new file mode 100644 index 0000000..395206e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive.pm @@ -0,0 +1,131 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive; +use base qw{Exporter}; + +our @EXPORT_OK = qw{get_input}; + +use Fcm::Util::ClassLoader; + +my $DEFAULT_IMPL_CLASS = 'Fcm::Interactive::InputGetter::CLI'; +my %DEFAULT_IMPL_CLASS_OPTIONS = (); + +my $IMPL_CLASS = $DEFAULT_IMPL_CLASS; +my %IMPL_CLASS_OPTIONS = %DEFAULT_IMPL_CLASS_OPTIONS; + +################################################################################ +# Returns the name of the current class/settings for getting input +sub get_impl { + return (wantarray() ? ($IMPL_CLASS, \%IMPL_CLASS_OPTIONS) : $IMPL_CLASS); +} + +################################################################################ +# Returns the name of the current class/settings for getting input +sub get_default_impl { + return ( + wantarray() + ? ($DEFAULT_IMPL_CLASS, \%DEFAULT_IMPL_CLASS_OPTIONS) + : $DEFAULT_IMPL_CLASS + ); +} + +################################################################################ +# Sets the name of the class/settings for getting input +sub set_impl { + my ($impl_class, $impl_class_options_ref) = @_; + if ($impl_class) { + $IMPL_CLASS = $impl_class; + if ($impl_class_options_ref) { + %IMPL_CLASS_OPTIONS = (%{$impl_class_options_ref}); + } + else { + %IMPL_CLASS_OPTIONS = (); + } + } +} + +################################################################################ +# Gets an input from the user and returns it +sub get_input { + my (%options) = @_; + my ($class_name, $class_options_ref) = get_impl(); + Fcm::Util::ClassLoader::load($class_name); + %options = map {lc($_), $options{$_}} keys(%options); + return $class_name->new({%{$class_options_ref}, %options})->invoke(); +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive + +=head1 SYNOPSIS + + use Fcm::Interactive; + Fcm::Interactive::set_impl('My::InputGetter', {option1 => 'value1', ...}); + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +Common interface for getting an interactive user reply. The default is to use a +L object +with no extra options. + +=head1 FUNCTIONS + +=over 4 + +=item get_impl() + +Returns the class that implements the function for get_input(%options). In +scalar context, returns the class name only. In list context, returns the class +name and the extra hash options that would be passed to its constructor. + +=item get_default_impl() + +Returns the defaut values for get_impl(). + +=item set_impl($impl_class,$impl_class_options_ref) + +Sets the class that implements the function for get_input(%options). The name +of the class is given in $impl_class. Any extra options that should be given to +the constructor should be set in the hash reference $impl_class_options_ref. + +=item get_input(%options) + +Calls the appropriate function to get an input string from the user, and +returns it. + +Input options are: I, for a short title of the prompt, I<message>, for +the message prompt, I<type> for the prompt type, and I<default> for the default +value of the return value. + +Prompt type can be YN (yes or no), YNA (yes, no or all) or input (for an input +string). + +=back + +=head1 SEE ALSO + +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, +L<Fcm::Interactive::InputGetter::CLI|Fcm::Interactive::InputGetter::CLI>, +L<Fcm::Interactive::InputGetter::GUI|Fcm::Interactive::InputGetter::GUI> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter.pm new file mode 100644 index 0000000..3fd77b7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter.pm @@ -0,0 +1,122 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive::InputGetter; + +use Carp qw{croak}; + +################################################################################ +# Constructor +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + ############################################################################ + # Returns the title of the prompt + 'title', + ############################################################################ + # Returns the message of the prompt + 'message', + ############################################################################ + # Returns the of the prompt + 'type', + ############################################################################ + # Returns the default return value + 'default', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + return $self->{$key}; + } +} + +################################################################################ +# Invokes the getter +sub invoke { + my ($self) = @_; + croak("Fcm::Interactive::InputGetter->invoke() not implemented."); +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive::TxtInputGetter + +=head1 SYNOPSIS + + use Fcm::Interactive::TxtInputGetter; + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +An object of this abstract class is used by +L<Fcm::Interactive|Fcm::Interactive> to get a user reply. + +=head1 METHODS + +=over 4 + +=item new($args_ref) + +Constructor, normally invoked via L<Fcm::Interactive|Fcm::Interactive>. + +Input options are: I<title>, for a short title of the prompt, I<message>, for +the message prompt, I<type> for the prompt type, and I<default> for the default +value of the return value. + +Prompt type can be YN (yes or no), YNA (yes, no or all) or input (for an input +string). + +=item get_title() + +Returns the title of the prompt. + +=item get_message() + +Returns the message of the prompt. + +=item get_type() + +Returns the type of the prompt, can be YN (yes or no), YNA (yes, no or all) or +input (for an input string). + +=item get_default() + +Returns the default return value of invoke(). + +=item invoke() + +Gets an input string from the user, and returns it. Sub-classes must override +this method. + +=back + +=head1 SEE ALSO + +L<Fcm::Interactive|Fcm::Interactive>, +L<Fcm::Interactive::TxtInputGetter|Fcm::Interactive::TxtInputGetter>, +L<Fcm::Interactive::GUIInputGetter|Fcm::Interactive::GUIInputGetter> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter/CLI.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter/CLI.pm new file mode 100644 index 0000000..e7818db --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter/CLI.pm @@ -0,0 +1,87 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive::InputGetter::CLI; +use base qw{Fcm::Interactive::InputGetter}; + +my $DEF_MSG = q{ (or just press <return> for "%s")}; +my %EXTRA_MSG_FOR = ( + yn => qq{\nEnter "y" or "n"}, + yna => qq{\nEnter "y", "n" or "a"}, +); +my %CHECKER_FOR = ( + yn => sub {$_[0] eq 'y' || $_[0] eq 'n'}, + yna => sub {$_[0] eq 'y' || $_[0] eq 'n' || $_[0] eq 'a'}, +); + +sub invoke { + my ($self) = @_; + my $type = $self->get_type() ? lc($self->get_type()) : q{}; + my $message + = $self->get_message() + . (exists($EXTRA_MSG_FOR{$type}) ? $EXTRA_MSG_FOR{$type} : q{}) + . ($self->get_default() ? sprintf($DEF_MSG, $self->get_default()) : q{}) + . q{: } + ; + while (1) { + print($message); + my $answer = readline(STDIN); + chomp($answer); + if (!$answer && $self->get_default()) { + $answer = $self->get_default(); + } + if (!exists($CHECKER_FOR{$type}) || $CHECKER_FOR{$type}->($answer)) { + return $answer; + } + } + return; +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive::InputGetter::CLI + +=head1 SYNOPSIS + + use Fcm::Interactive; + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +This is a solid implementation of +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>. It gets a user +reply from STDIN using a prompt on STDOUT. + +=head1 METHODS + +See L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter> for a list of +methods. + +=head1 TO DO + +Use IO::Prompt. + +=head1 SEE ALSO + +L<Fcm::Interactive|Fcm::Interactive>, +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, +L<Fcm::Interactive::InputGetter::GUI|Fcm::Interactive::InputGetter::GUI> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter/GUI.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter/GUI.pm new file mode 100644 index 0000000..5cd78e0 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Interactive/InputGetter/GUI.pm @@ -0,0 +1,248 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Interactive::InputGetter::GUI; +use base qw{Fcm::Interactive::InputGetter}; + +use Tk; + +################################################################################ +# Returns the geometry string for the pop up message box +sub get_geometry { + my ($self) = @_; + return $self->{geometry}; +} + +################################################################################ +# Invokes the getter +sub invoke { + my ($self) = @_; + my $answer; + local $| = 1; + + # Create a main window + my $mw = MainWindow->new(); + $mw->title($self->get_title()); + + # Define the default which applies if the dialog box is just closed or + # the user selects 'cancel' + $answer = $self->get_default() ? $self->get_default() : q{}; + + if (defined($self->get_type()) && $self->get_type() =~ qr{\A yn}ixms) { + # Create a yes-no(-all) dialog box + + # If TYPE is YNA then add a third button: 'all' + my $buttons = $self->get_type() =~ qr{a \z}ixms ? 3 : 2; + + # Message of the dialog box + $mw->Label('-text' => $self->get_message())->grid( + '-row' => 0, + '-column' => 0, + '-columnspan' => $buttons, + '-padx' => 10, + '-pady' => 10, + ); + + # The "yes" button + my $y_b = $mw->Button( + '-text' => 'Yes', + '-underline' => 0, + '-command' => sub {$answer = 'y'; $mw->destroy()}, + ) + ->grid('-row' => 1, '-column' => 0, '-padx' => 5, '-pady' => 5); + + # The "no" button + my $n_b = $mw->Button ( + '-text' => 'No', + '-underline' => 0, + '-command' => sub {$answer = 'n'; $mw->destroy()}, + ) + ->grid('-row' => 1, '-column' => 1, '-padx' => 5, '-pady' => 5); + + # The "all" button + my $a_b; + if ($buttons == 3) { + $a_b = $mw->Button( + '-text' => 'All', + '-underline' => 0, + '-command' => sub {$answer = 'a'; $mw->destroy()}, + ) + ->grid('-row' => 1, '-column' => 2, '-padx' => 5, '-pady' => 5); + } + + # Keyboard binding + if ($buttons == 3) { + $mw->bind('<Key>' => sub { + my $button + = $Tk::event->K() eq 'Y' || $Tk::event->K() eq 'y' ? $y_b + : $Tk::event->K() eq 'N' || $Tk::event->K() eq 'n' ? $n_b + : $Tk::event->K() eq 'A' || $Tk::event->K() eq 'a' ? $a_b + : undef + ; + if (defined($button)) { + $button->invoke(); + } + }); + } + else { + $mw->bind('<Key>' => sub { + my $button + = $Tk::event->K() eq 'Y' || $Tk::event->K() eq 'y' ? $y_b + : $Tk::event->K() eq 'N' || $Tk::event->K() eq 'n' ? $n_b + : undef + ; + if (defined($button)) { + $button->invoke(); + } + }); + } + + # Handle the situation when the user attempts to quit the window + $mw->protocol('WM_DELETE_WINDOW', sub { + if (self->get_default()) { + $answer = $self->get_default(); + } + $mw->destroy(); + }); + } + else { + # Create a dialog box to obtain an input string + # Message of the dialog box + $mw->Label('-text' => $self->get_message())->grid( + '-row' => 0, + '-column' => 0, + '-padx' => 5, + '-pady' => 5, + ); + + # Entry box for the user to type in the input string + my $entry = $answer; + my $input_e = $mw->Entry( + '-textvariable' => \$entry, + '-width' => 40, + ) + ->grid( + '-row' => 0, + '-column' => 1, + '-sticky' => 'ew', + '-padx' => 5, + '-pady' => 5, + ); + + my $b_f = $mw->Frame->grid( + '-row' => 1, + '-column' => 0, + '-columnspan' => 2, + '-sticky' => 'e', + ); + + # An OK button to accept the input string + my $ok_b = $b_f->Button ( + '-text' => 'OK', + '-command' => sub {$answer = $entry; $mw->destroy()}, + ) + ->grid('-row' => 0, '-column' => 0, '-padx' => 5, '-pady' => 5); + + # A Cancel button to reject the input string + my $cancel_b = $b_f->Button( + '-text' => 'Cancel', + '-command' => sub {$answer = undef; $mw->destroy()}, + ) + ->grid('-row' => 0, '-column' => 1, '-padx' => 5, '-pady' => 5); + + # Keyboard binding + $mw->bind ('<Key>' => sub { + if ($Tk::event->K eq 'Return' or $Tk::event->K eq 'KP_Enter') { + $ok_b->invoke(); + } + elsif ($Tk::event->K eq 'Escape') { + $cancel_b->invoke(); + } + }); + + # Allow the entry box to expand + $mw->gridColumnconfigure(1, '-weight' => 1); + + # Set initial focus on the entry box + $input_e->focus(); + $input_e->icursor('end'); + } + + $mw->geometry($self->get_geometry()); + + # Switch on "always on top" property for $mw + $mw->property( + qw/set _NET_WM_STATE ATOM/, + 32, + ['_NET_WM_STATE_STAYS_ON_TOP'], + ($mw->toplevel()->wrapper())[0], + ); + + MainLoop(); + return $answer; +} + +1; +__END__ + +=head1 NAME + +Fcm::Interactive::InputGetter::GUI + +=head1 SYNOPSIS + + use Fcm::Interactive; + $answer = Fcm::Interactive::get_input( + title => 'My title', + message => 'Would you like to ...?', + type => 'yn', + default => 'n', + ); + +=head1 DESCRIPTION + +This is a solid implementation of +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>. It gets a user +reply from a TK pop up message box. + +=head1 METHODS + +See L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter> for a list of +inherited methods. + +=over 4 + +=item new($args_ref) + +As in L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, but also +accept a I<geometry> element for setting the geometry string of the pop up +message box. + +=item get_geometry() + +Returns the geometry string for the pop up message box. + +=back + +=head1 TO DO + +Tidy up the logic of invoke(). Separate the logic for YN/A box and string input +box, probably using a strategy pattern. Factor out the logic for the display +and the return value. + +=head1 SEE ALSO + +L<Fcm::Interactive|Fcm::Interactive>, +L<Fcm::Interactive::InputGetter|Fcm::Interactive::InputGetter>, +L<Fcm::Interactive::InputGetter::CLI|Fcm::Interactive::InputGetter::CLI> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword.pm new file mode 100644 index 0000000..0a7c9cc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword.pm @@ -0,0 +1,376 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword; + +use Carp qw{croak}; +use Fcm::Config; +use Fcm::Exception; +use Fcm::Keyword::Config; +use Fcm::Keyword::Exception; +use URI; + +my $ENTRIES; + +my $PREFIX_OF_LOCATION_KEYWORD = 'fcm'; +my $PATTERN_OF_RESERVED_REVISION_KEYWORDS + = qr{\A (?:\d+|HEAD|BASE|COMMITTED|PREV|\{[^\}]+\}) \z}ixms; + +################################################################################ +# Returns the Fcm::Keyword::Entries object for storing the location entries +sub get_entries { + my ($reset) = @_; + if ($reset || !$ENTRIES) { + $ENTRIES = Fcm::Keyword::Config::get_entries('LOCATION_ENTRIES'); + } + return $ENTRIES; +} + +################################################################################ +# Returns a list of Fcm::Keyword::Entry::Location objects matching $in_loc +sub get_location_entries_for { + my ($in_loc) = @_; + my ($loc, $rev, @entry_trail_refs) = _parse_loc($in_loc); + return (map {$_->[0]} @entry_trail_refs); +} + +################################################################################ +# Returns the prefix of location keyword (with or without the delimiter). +sub get_prefix_of_location_keyword { + my ($with_delimiter) = @_; + return $PREFIX_OF_LOCATION_KEYWORD . ($with_delimiter ? ':' : ''); +} + +################################################################################ +# Expands (the keywords in) the specfied location (and REV), and returns them +sub expand { + my ($in_loc, $in_rev) = @_; + my ($loc, $rev) = _expand($in_loc, $in_rev); + return _unparse_loc($loc, $rev, $in_rev); +} + +################################################################################ +# Returns the corresponding browser URL for the input VC location +sub get_browser_url { + my ($in_loc, $in_rev) = @_; + + my ($loc, $rev, @entry_trail_refs) = _expand($in_loc, $in_rev); + if (!@entry_trail_refs) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: cannot be mapped to a browser URL", $in_loc, + )})); + } + + my @entries = map {$_->[0]} @entry_trail_refs; + my $location_component_pattern + = _get_browser_url_setting(\@entries, 'location_component_pattern'); + my $browser_url_template + = _get_browser_url_setting(\@entries, 'browser_url_template'); + my $browser_rev_template + = _get_browser_url_setting(\@entries, 'browser_rev_template'); + + if ( + $location_component_pattern + && $browser_url_template + && $browser_rev_template + ) { + my $uri = URI->new($loc); + my $sps = $uri->opaque(); + my @matches = $sps =~ $location_component_pattern; + if (@matches) { + my $result = $browser_url_template; + for my $field_number (1 .. @matches) { + my $match = $matches[$field_number - 1]; + $result =~ s/\{ $field_number \}/$match/xms; + } + my $rev_field = scalar(@matches) + 1; + if ($rev) { + my $rev_string = $browser_rev_template; + $rev_string =~ s/\{1\}/$rev/xms; + $result =~ s/\{ $rev_field \}/$rev_string/xms; + } + else { + $result =~ s/\{ $rev_field \}//xms; + } + return $result; + } + } + else { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: mapping templates not defined correctly", $in_loc, + )})); + } +} + +################################################################################ +# Returns a browser URL setting, helper function for get_browser_url() +sub _get_browser_url_setting { + my ($entries_ref, $setting) = @_; + my $getter = "get_$setting"; + for my $entry (@{$entries_ref}) { + my $setting = $entry->$getter(); + if ($setting) { + return $setting; + } + } + my $config = Fcm::Config->instance(); + return $config->setting('URL_BROWSER_MAPPING_DEFAULT', uc($setting)); +} + +################################################################################ +# Un-expands the specfied location (and REV) to keywords, and returns them +sub unexpand { + my ($in_loc, $in_rev) = @_; + my ($loc, $rev, @entry_trail_refs) = _parse_loc($in_loc, $in_rev); + if (@entry_trail_refs) { + my ($entry, $trail) = @{$entry_trail_refs[0]}; + if ($rev) { + GET_REV_KEY: + for my $entry_trail_ref (@entry_trail_refs) { + my ($e, $t) = @{$entry_trail_ref}; + my $rev_key + = $e->get_revision_entries()->get_entry_by_value($rev); + if ($rev_key) { + $rev = $rev_key->get_key(); + last GET_REV_KEY; + } + } + } + $loc = get_prefix_of_location_keyword(1) . $entry->get_key() . $trail; + return _unparse_loc($loc, $rev, $in_rev); + } + return _unparse_loc($in_loc, $in_rev, $in_rev); +} + +################################################################################ +# Expands (the keywords in) the specfied location (and REV), and returns them +sub _expand { + my ($in_loc, $in_rev) = @_; + my ($loc, $rev, @entry_trail_refs) = _parse_loc($in_loc, $in_rev); + if (@entry_trail_refs) { + my ($entry, $trail) = @{$entry_trail_refs[0]}; + $loc = $entry->get_value() . $trail; + if ($rev && $rev !~ $PATTERN_OF_RESERVED_REVISION_KEYWORDS) { + my $r; + GET_REV: + for my $entry_trail_ref (@entry_trail_refs) { + my ($e, $t) = @{$entry_trail_ref}; + $r = $e->get_revision_entries()->get_entry_by_key($rev); + if ($r) { + $rev = $r->get_value(); + last GET_REV; + } + } + if (!$r) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: %s: unknown revision keyword", + $loc, $rev, + )})); + } + } + } + return ($loc, $rev, @entry_trail_refs); +} + +################################################################################ +# Parses $in_loc (and $in_rev) +sub _parse_loc { + my ($in_loc, $in_rev) = @_; + if (!$in_loc) { + croak(Fcm::Exception->new({ + message => 'internal error: $in_loc not defined', + })); + } + if ($in_loc) { + if (!defined($in_rev)) { + my ($loc, $rev) = $in_loc =~ qr{\A (.+) \@ ([^/\@]+) \z}xms; + if ($loc && $rev) { + return ($loc, $rev, _get_loc_entry($loc)); + } + else { + return ($in_loc, $in_rev, _get_loc_entry($in_loc)); + } + } + return ($in_loc, $in_rev, _get_loc_entry($in_loc)); + } + return; +} + +################################################################################ +# Returns a list of keyword entries/trailing path pairs for the input location +sub _get_loc_entry { + my ($loc) = @_; + if ($loc) { + my $uri = URI->new($loc); + if ( + $uri->scheme() + && $uri->scheme() eq get_prefix_of_location_keyword() + ) { + my ($key, $trail) = $uri->opaque() =~ qr{\A ([^/\@]+) (.*) \z}xms; + my $entry = get_entries()->get_entry_by_key($key); + if (!$entry || !$entry->get_value()) { + die(Fcm::Keyword::Exception->new({message => sprintf( + "%s: unknown FCM location keyword", $loc, + )})); + } + $loc = $entry->get_value() . ($trail ? $trail : q{}); + } + my @entry_trail_pairs = (); + my $lead = $loc; + GET_ENTRY: + while ($lead) { + my $entry = get_entries()->get_entry_by_value($lead); + if ($entry) { + my $trail = substr($loc, length($lead)); + push @entry_trail_pairs, [$entry, $trail]; + } + if (!($lead =~ s{/+ [^/]* \z}{}xms)) { + last GET_ENTRY; + } + } + if (@entry_trail_pairs) { + return @entry_trail_pairs; + } + else { + return; + } + } + return; +} + +################################################################################ +# If $in_rev, returns (LOC, REV). Otherwise, returns LOC@REV +sub _unparse_loc { + my ($loc, $rev, $in_rev) = @_; + if (!$loc) { + return; + } + return ($in_rev ? ($loc, $rev) : join(q{@}, $loc, ($rev ? $rev : ()))); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword + +=head1 SYNOPSIS + + use Fcm::Keyword; + + $loc = Fcm::Keyword::expand('fcm:namespace/path@rev-keyword'); + $loc = Fcm::Keyword::unexpand('svn://host/namespace/path@1234'); + + ($loc, $rev) = Fcm::Keyword::expand('fcm:namespace/path', 'rev-keyword'); + ($loc, $rev) = Fcm::Keyword::unexpand('svn://host/namespace/path', 1234); + + $loc = Fcm::Keyword::get_browser_url('fcm:namespace/path'); + $loc = Fcm::Keyword::get_browser_url('svn://host/namespace/path'); + + $loc = Fcm::Keyword::get_browser_url('fcm:namespace/path@1234'); + $loc = Fcm::Keyword::get_browser_url('svn://host/namespace/path@1234'); + + $loc = Fcm::Keyword::get_browser_url('fcm:namespace/path', 1234); + $loc = Fcm::Keyword::get_browser_url('svn://host/namespace/path', 1234); + + $entries = Fcm::Keyword::get_entries(); + +=head1 DESCRIPTION + +This module contains utilities to expand and unexpand FCM location and revision +keywords. + +=head1 FUNCTIONS + +=over 4 + +=item expand($loc) + +Expands FCM keywords in $loc and returns the result. + +If $loc is a I<fcm> scheme URI, the leading part (before any "/" or "@" +characters) of the URI opaque is the namespace of a FCM location keyword. This +is expanded into the actual value. Optionally, $loc can be suffixed with a peg +revision (an "@" followed by any characters). If a peg revision is a FCM +revision keyword, it is expanded into the actual revision. + +=item expand($loc,$rev) + +Same as C<expand($loc)>, but $loc should not contain a peg revision. Returns a +list containing the expanded version of $loc and $rev. + +=item get_browser_url($loc) + +Given a repository $loc in a known keyword namespace, returns the corresponding +URL for the code browser. + +Optionally, $loc can be suffixed with a peg revision (an "@" followed by any +characters). + +=item get_browser_url($loc,$rev) + +Same as get_browser_url($loc), but the revision should be specified using $rev +but not pegged with $loc. + +=item get_entries([$reset]) + +Returns the L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object for storing +location keyword entries. If $reset if true, reloads the entries. + +=item get_location_entries_for($loc) + +Returns a list of L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location> +objects matching $loc. + +=item get_prefix_of_location_keyword($with_delimiter) + +Returns the prefix of a FCM location keyword, (currently "fcm"). If +$with_delimiter is specified and is true, returns the prefix with the delimiter, +(currently "fcm:"). + +=item unexpand($loc) + +Does the opposite of expand($loc). Returns the FCM location keyword equivalence +of $loc. If the $loc can be mapped using 2 or more namespaces, the namespace +that results in the longest substitution is used. Optionally, $loc can be +suffixed with a peg revision (an "@" followed by any characters). If a peg +revision is a known revision, it is turned into its corresponding revision +keyword. + +=item unexpand($loc,$rev) + +Same as unexpand($loc), but $loc should not contain a peg revision. Returns a +list containing the unexpanded version of $loc and $rev + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L<Fcm::Keyword::Exception|Fcm::Keyword::Exception> + +Functions in this module may die() with this exception when it fails to expand +a keyword. + +=back + +=head1 SEE ALSO + +L<Fcm::Keyword::Config|Fcm::Keyword::Config>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location>, +L<Fcm::Keyword::Exception|Fcm::Keyword::Exception> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Config.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Config.pm new file mode 100644 index 0000000..23d018c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Config.pm @@ -0,0 +1,143 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Config; + +use Carp; +use Fcm::Keyword::Entries; +use Fcm::Keyword::Exception; +use Fcm::Util::ClassLoader; + +our %CONFIG_OF = ( + LOCATION_ENTRIES => { + entry_class => 'Fcm::Keyword::Entry::Location', + loaders => [ + { + class => 'Fcm::Keyword::Loader::Config::Location', + }, + ], + }, + REVISION_ENTRIES => { + entry_class => 'Fcm::Keyword::Entry', + loaders => [ + { + class => 'Fcm::Keyword::Loader::Config::Revision', + options => [{key => 'namespace', valuekey => 'key'}], + }, + { + class => 'Fcm::Keyword::Loader::VC::Revision', + options => [{key => 'source', valuekey => 'value'}], + }, + ], + }, +); + +################################################################################ +# Returns a Fcm::Keyword::Entries object for given configuration +sub get_entries { + my ($context, $args_ref) = @_; + if (!exists($CONFIG_OF{$context})) { + croak(Fcm::Keyword::Exception->new({message => sprintf( + "%s: keyword configuration not found", $context, + )})); + } + my $config_ref = $CONFIG_OF{$context}; + my @loaders; + if (exists($config_ref->{loaders})) { + for my $loader_config (@{$config_ref->{loaders}}) { + my $class = $loader_config->{class}; + Fcm::Util::ClassLoader::load($class); + my %options; + if (exists($loader_config->{options})) { + for my $option_ref (@{$loader_config->{options}}) { + my $key = $option_ref->{key}; + my $value; + if (exists($option_ref->{value})) { + $value = $option_ref->{value}; + } + elsif ( + exists($option_ref->{valuekey}) + && $args_ref + && ref($args_ref) eq 'HASH' + && exists($args_ref->{$option_ref->{valuekey}}) + ) { + $value = $args_ref->{$option_ref->{valuekey}}; + } + $options{$key} = $value; + } + } + push @loaders, $class->new(\%options); + } + } + my %entries_options = ( + (@loaders ? (loaders => \@loaders) : ()), + ( + exists($config_ref->{entry_class}) + ? (entry_class => $config_ref->{entry_class}) + : () + ), + ); + return Fcm::Keyword::Entries->new(\%entries_options); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Config + +=head1 SYNOPSIS + + use Fcm::Keyword::Config; + +=head1 DESCRIPTION + +This module stores the default configuration used by modules in the +L<Fcm::Keyword> family. + +=head1 FUNCTIONS + +=over 4 + +=item get_entries($context,$args_ref) + +Returns a L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object for a given +$context. If there is no matching $context in the configuration, croak() with a +L<Fcm::Keyword::Exception|Fcm::Keyword::Exception>. $args_ref is an optional +argument, which should be a reference to a hash containing a I<key> and a +I<value> element. It can be used by this function to set up the constructor +options in the loaders of the returned +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object. + +=back + +=head1 DIAGNOSTICS + +=head1 TO DO + +Allow configuration to be changed in runtime. + +Convert this module to OO? + +Separate configuration from logic if this module becomes any bigger. + +Unit tests. + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Exception|Fcm::Keyword::Exception>, +L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entries.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entries.pm new file mode 100644 index 0000000..9bbd028 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entries.pm @@ -0,0 +1,211 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Entries; + +use Carp qw{croak}; +use Fcm::Util::ClassLoader; + +sub new { + my ($class, $args_ref) = @_; + return bless( + { + entry_class => 'Fcm::Keyword::Entry', + entry_by => {key => {}, value => {}}, + has_loaded_entries_from => {}, + loaders => [], + ($args_ref && ref($args_ref) eq 'HASH' ? %{$args_ref} : ()), + }, + $class, + ); +} + +################################################################################ +# Returns the class of entries stored by this entries list +sub get_entry_class { + my ($self) = @_; + return $self->{entry_class}; +} + +################################################################################ +# Returns all entries +sub get_all_entries { + my ($self) = @_; + if (!%{$self->{entry_by}{key}}) { + # Nothing set, attempt to load entries + $self->load_entries(); + } + if (wantarray()) { + return values(%{$self->{entry_by}{key}}); + } + else { + return [values(%{$self->{entry_by}{key}})]; + } +} + +################################################################################ +# Methods: get_entry_by_* +for my $name ( + ### Returns an entry with a matching key + 'key', + ### Returns an entry with a matching value + 'value' +) { + no strict qw{refs}; + my $method = "get_entry_by_$name"; + *$method = sub { + my ($self, $search_key) = @_; + if (!defined($search_key)) { + return; + } + my $sk = ($name eq 'key') ? uc($search_key) : $search_key; + if (!exists($self->{entry_by}{$name}{$sk})) { + $self->load_entries($name, $sk); + } + if (exists($self->{entry_by}{$name}{$sk})) { + return $self->{entry_by}{$name}{$sk}; + } + else { + return; + } + } +} + +################################################################################ +# Adds an entry +sub add_entry { + my ($self, $key, $value, $args_ref) = @_; + Fcm::Util::ClassLoader::load($self->get_entry_class()); + my $entry = $self->get_entry_class()->new({ + key => uc($key), + value => $value, + ($args_ref && ref($args_ref) eq 'HASH' ? %{$args_ref} : ()), + }); + $self->{entry_by}{key}{uc($key)} = $entry; + $self->{entry_by}{value}{$value} = $entry; + return $entry; +} + +################################################################################ +# Returns the loaders for this entries list +sub get_loaders { + my ($self) = @_; + return (wantarray() ? @{$self->{loaders}} : $self->{loaders}); +} + +################################################################################ +# Loads entries using its loaders +sub load_entries { + my ($self, $name, $search_key) = @_; + LOADER: + for my $loader ($self->get_loaders()) { + if ($self->{has_loaded_entries_from}{$loader->get_source()}) { + next LOADER; + } + $self->{has_loaded_entries_from}{$loader->get_source()} + = $loader->load_to($self); + if ($name && exists($self->{entry_by}{$name}{$search_key})) { + last LOADER; + } + } +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Entries + +=head1 SYNOPSIS + + use Fcm::Keyword::Entries; + + my $entries = Fcm::Keyword::Entries->new({ + entry_class => $entry_class, + loaders => \@loaders, + }); + $entry = $entries->get_entry_by_key($key); + $entry = $entries->get_entry_by_value($value); + + for my $entry ($entries->get_entries()) { + # ... + } + + $entries->add_entry($key, $value); + +=head1 DESCRIPTION + +This module is used to manipulate FCM keyword entries. It is used by +L<Fcm::Keyword|Fcm::Keyword> to store keyword entries, which are +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> objects. + +=head1 METHODS + +=over 4 + +=item C<new({entry_class =E<gt> $entry_class, loaders =E<gt> \@loaders})> + +Constructor. The argument should be a reference to hash, where: + +I<entry_class> is a string representing the class name of entries in this +object. The class must be a sub-class of +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>. The default is +"L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>". + +I<loaders> is a reference to an array of +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader> objects, which will be used to +load entries into this object. The default is an empty array. + +=item add_entry($key,$value) + +Adds an entry. Returns the added entry. (Keys are converted to uppercases +automatically.) + +=item get_all_entries() + +Returns all entries that are currently loaded. + +=item get_entry_by_key($key) + +Return an entry, whose key matches $key. (Search is case-insensitive.) Returns +undef if there is no matching entry. + +=item get_entry_by_value($value) + +Return an entry, whose value matches $value. (Search is case-sensitive.) +Returns undef if there is no matching entry. + +=item get_loaders() + +Returns the loaders for loading entries. + +=item load_entries() + +Loads entries from its loaders, as returned by get_loaders(). This method can +also be triggered by get_all_entries(), if the entry list is empty, or by +get_entry_by_key($key) and get_entry_by_value($value) methods, if there is no +matching entry in the current lookup lists. + +=back + +=head1 TO DO + +Handle duplicated entries in add_entry($key,$value). + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entry.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entry.pm new file mode 100644 index 0000000..cce065f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entry.pm @@ -0,0 +1,83 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Entry; + +sub new { + my ($class, $args_ref) = @_; + if (!$args_ref) { + $args_ref = {}; + } + return bless({%{$args_ref}}, $class); +} + +################################################################################ +### Methods: get_* +for my $name ( + # Returns the key of this entry + 'key', + # Returns the value of this entry + 'value', +) { + no strict qw{refs}; + my $getter = "get_$name"; + *$getter = sub { + my ($self) = @_; + return $self->{$name}; + } +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Entry + +=head1 SYNOPSIS + + use Fcm::Keyword::Entry; + + $entry = Fcm::Keyword::Entry->new({key => $key, value => $value}); + $key = $entry->get_key(); + $value = $entry->get_value(); + +=head1 DESCRIPTION + +An object of this class represents a FCM keyword entry. + +=head1 METHODS + +=over 4 + +=item C<new({key =E<gt> $key, value =E<gt> $value})> + +Constructor. + +=item get_key() + +Returns the key of this keyword entry. + +=item get_value() + +Returns the value of this keyword entry. + +=back + +Simple formatter for displaying an entry. + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entry/Location.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entry/Location.pm new file mode 100644 index 0000000..c7f118f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Entry/Location.pm @@ -0,0 +1,146 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Entry::Location; +use base qw{Fcm::Keyword::Entry}; + +use Fcm::Keyword::Config; + +sub new { + my ($class, $args_ref) = @_; + if (!$args_ref) { + $args_ref = {}; + } + $args_ref = { + browser_rev_template => undef, + browser_url_template => undef, + implied_entry_list => [], + is_implied => 0, + location_component_pattern => undef, + revision_entries => Fcm::Keyword::Config::get_entries( + 'REVISION_ENTRIES', $args_ref, + ), + %{$args_ref}, + }, + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Methods: get_* +for my $key ( + # Returns a template for constructing the browser URL + 'browser_url_template', + # Returns a template for constructing the revision part in the browser URL + 'browser_rev_template', + # Returns a list of entries implied this entry + 'implied_entry_list', + # Returns the component pattern for a location matching this entry + 'location_component_pattern', + # Returns the entries for revision keywords + 'revision_entries', +) { + no strict qw{refs}; + my $getter = "get_$key"; + *$getter = sub { + my ($self) = @_; + return $self->{$key}; + } +} + +################################################################################ +# Returns true if this is an implied entry +sub is_implied { + my ($self) = @_; + return $self->{is_implied}; +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Entry::Location + +=head1 SYNOPSIS + + use Fcm::Keyword::Entry::Location; + + $entry = Fcm::Keyword::Entry::Location->new({ + key => $key, value => $value, # ... + }); + + $key = $entry->get_key(); + $value = $entry->get_value(); + $revision_entries = $entry->get_revision_entries(); + +=head1 DESCRIPTION + +This is a sub-class of L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>. An object of +this class represents a FCM location keyword entry. + +=head1 METHODS + +See L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> for inherited methods. + +=over 4 + +=item new($args_ref) + +Constructor. + +=item get_browser_url_template() + +Returns the template string for constructing the browser URL. The string {1}, +{2}, {3}, etc in the template string will be substituted by the components +captured by the location component pattern and the revision template. See +C<get_url_component_pattern()> and C<get_browser_rev_template()>. + +=item get_browser_rev_template() + +Returns the template string for constructing the revision part of the browser +URL. The string {1} in the template string will be substituted by the revision. +See C<get_browser_url_template()>. + +=item get_implied_entry_list() + +Returns a list of entries implied by this entry. + +=item get_location_component_pattern() + +Returns a regular expression, when matched against the scheme-specific-part in +the actual URI of a location in the namespace of this keyword entry, will +capture a list of components, which can then be used to replace the numbered +fields in the browser URL template. See C<get_browser_url_template()>. + +=item get_revision_entries() + +Returns a L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object containing the +revision keyword entries of this location. + +=item is_implied() + +Returns true if this is an implied entry. + +=back + +=head1 TO DO + +Introduce a Fcm::Keyword::Config module to store entries constructor setting. + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Config|Fcm::Keyword::Config>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Exception.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Exception.pm new file mode 100644 index 0000000..9558502 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Exception.pm @@ -0,0 +1,42 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Exception; +use base qw{Fcm::Exception}; + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Exception + +=head1 SYNOPSIS + + use Carp qw{croak}; + use Fcm::Keyword::Exception; + croak(Fcm::Keyword::Exception->new({message => 'something is wrong'})); + +=head1 DESCRIPTION + +This class extends L<Fcm::Exception|Fcm::Exception>. This exception is thrown +on errors associated with the command line interface. + +=head1 METHODS + +See L<Fcm::Exception|Fcm::Exception> for a list of methods. + +=head1 SEE ALSO + +L<Fcm::Exception|Fcm::Exception> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entries.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entries.pm new file mode 100644 index 0000000..19d6c85 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entries.pm @@ -0,0 +1,77 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Formatter::Entries; + +use Fcm::Keyword::Formatter::Entry; + +################################################################################ +# Constructor +sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); +} + +################################################################################ +# Formats a keyword entry +sub format { + my ($self, $entries) = @_; + my $formatter = Fcm::Keyword::Formatter::Entry->new(); + my $return = q{}; + for my $entry ( + sort {$a->get_key() cmp $b->get_key()} + grep {!$_->can('is_implied') || !$_->is_implied()} + $entries->get_all_entries() + ) { + $return .= $formatter->format($entry); + } + return $return; +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Formatter::Entries + +=head1 SYNOPSIS + + use Fcm::Keyword::Formatter::Entries; + $formatter = Fcm::Keyword::Formatter::Entries->new(); + print($formatter->format($entries)); + +=head1 DESCRIPTION + +An object of this class is used to format a keyword entries object. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item format($entries) + +Returns a simple string representation of $entries. + +=back + +=head1 SEE ALSO + +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Formatter::Entry|Fcm::Keyword::Formatter::Entry> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entry.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entry.pm new file mode 100644 index 0000000..55edafc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entry.pm @@ -0,0 +1,64 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Formatter::Entry; + +################################################################################ +# Constructor +sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); +} + +################################################################################ +# Formats a keyword entry +sub format { + my ($self, $entry) = @_; + return sprintf("%s = %s\n", $entry->get_key(), $entry->get_value()); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Formatter::Entry + +=head1 SYNOPSIS + + use Fcm::Keyword::Formatter::Entry; + $formatter = Fcm::Keyword::Formatter::Entry->new(); + print($formatter->format($entry)); + +=head1 DESCRIPTION + +An object of this class is used to format a keyword entry. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item format($entry) + +Returns a simple string representation of $entry. + +=back + +=head1 SEE ALSO + +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entry/Location.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entry/Location.pm new file mode 100644 index 0000000..025b88e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Formatter/Entry/Location.pm @@ -0,0 +1,72 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Formatter::Entry::Location; +use base qw{Fcm::Keyword::Formatter::Entry}; + +use Fcm::Config; +use Fcm::Keyword::Formatter::Entries; + +################################################################################ +# Formats a keyword entry +sub format { + my ($self, $entry) = @_; + my $return = $self->SUPER::format($entry); + for my $implied_entry (@{$entry->get_implied_entry_list()}) { + $return .= $self->SUPER::format($implied_entry); + } + if (@{$entry->get_revision_entries()->get_all_entries()}) { + my $formatter = Fcm::Keyword::Formatter::Entries->new(); + $return .= "\n[revision keyword]\n"; + $return .= $formatter->format($entry->get_revision_entries()); + } + return $return; +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Formatter::Entry::Location + +=head1 SYNOPSIS + + use Fcm::Keyword::Formatter::Entry::Location; + $formatter = Fcm::Keyword::Formatter::Entry::Location->new(); + print($formatter->format($entry)); + +=head1 DESCRIPTION + +An object of this class is used to format the detail in a location keyword entry. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item format($entry) + +Returns a string representation of $entry. + +=back + +=head1 SEE ALSO + +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Formatter::Entry|Fcm::Keyword::Formatter::Entry>, +L<Fcm::Keyword::Formatter::Entries|Fcm::Keyword::Formatter::Entries> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader.pod b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader.pod new file mode 100644 index 0000000..bbdf321 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader.pod @@ -0,0 +1,43 @@ +=head1 NAME + +Fcm::Keyword::Loader + +=head1 SYNOPSIS + + $loader->load_to($entries); + +=head1 DESCRIPTION + +This is an interface of a class that loads FCM keywords into a +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object. + +=head1 METHODS + +=over 4 + +=item get_source() + +The name of the source where this loader loads its FCM keywords from. + +=item load_to($entries) + +Loads FCM keywords into $entries, which should be a +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object. Returns the number of +successfully loaded entries. + +=back + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Loader::Config::Location|Fcm::Keyword::Loader::Config::Location>, +L<Fcm::Keyword::Loader::Config::Revision|Fcm::Keyword::Loader::Config::Revision>, +L<Fcm::Keyword::Loader::VC::Revision|Fcm::Keyword::Loader::VC::Revision> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/Config/Location.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/Config/Location.pm new file mode 100644 index 0000000..8dedac5 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/Config/Location.pm @@ -0,0 +1,128 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Loader::Config::Location; + +use Fcm::Config; + +my %IMPLIED_NAMESPACE_SUFFIX = (tr => 'trunk', br => 'branches', tg => 'tags'); + +sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); +} + +################################################################################ +# Returns 'Fcm::Config' +sub get_source { + my ($self) = @_; + return 'Fcm::Config'; +} + +################################################################################ +# Loads location keywords from Fcm::Config to $entries +sub load_to { + my ($self, $entries) = @_; + my $config = $self->get_source()->instance(); + my $load_counter = 0; + for my $key (keys(%{$config->setting('URL')})) { + my $value = $config->setting('URL', $key); + my $location_component_pattern = $config->setting( + 'URL_BROWSER_MAPPING', $key, 'LOCATION_COMPONENT_PATTERN'); + my $browser_url_template = $config->setting( + 'URL_BROWSER_MAPPING', $key, 'BROWSER_URL_TEMPLATE'); + my $browser_rev_template = $config->setting( + 'URL_BROWSER_MAPPING', $key, 'BROWSER_REV_TEMPLATE'); + my $entry = $entries->add_entry( + $key, + $value, + { + location_component_pattern => $location_component_pattern, + browser_url_template => $browser_url_template, + browser_rev_template => $browser_rev_template, + }, + ); + $load_counter++; + + # Set up implied keywords + for my $suffix (keys(%IMPLIED_NAMESPACE_SUFFIX)) { + my $value_suf = $value . '/' . $IMPLIED_NAMESPACE_SUFFIX{$suffix}; + for my $join (q{_}, q{-}) { + my $implied_entry = $entries->add_entry( + uc($key . $join . $suffix), + $value_suf, + {is_implied => 1}, + ); + push(@{$entry->get_implied_entry_list()}, $implied_entry); + $load_counter++; + } + } + } + return ($config->is_initialising() ? 0 : defined($load_counter)); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Loader::Config::Location + +=head1 SYNOPSIS + + $loader = Fcm::Keyword::Loader::Config::Location->new(); + $loader->load_to($entries); + +=head1 DESCRIPTION + +This class implements the L<Fcm::Keyword::Loader|Fcm::Keyword::Loader> +interface. + +Loads location keywords from L<Fcm::Config|Fcm::Config> into a +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object containing +L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location> objects. + +=head1 METHODS + +=over 4 + +=item new() + +Constructor. + +=item get_source() + +Returns the string "L<Fcm::Config|Fcm::Config>". + +=item load_to($entries) + +Loads location keywords and implied keywords from L<Fcm::Config|Fcm::Config> to +$entries. It also loads settings for mapping location to browser URL. Returns +true on success. (However, if L<Fcm::Config|Fcm::Config> is initialising, +returns false to force a reload next time.) + +=back + +=head1 TO DO + +Need a more flexible system for implied keywords. + +=head1 SEE ALSO + +L<Fcm::Config|Fcm::Config>, +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader>, +L<Fcm::Keyword::Loader::Config::Revision|Fcm::Keyword::Loader::Config::Revision> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/Config/Revision.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/Config/Revision.pm new file mode 100644 index 0000000..3c9d7d3 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/Config/Revision.pm @@ -0,0 +1,110 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Loader::Config::Revision; + +use Fcm::Config; + +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns the namespace where the revision keywords belong +sub get_namespace { + my ($self) = @_; + return $self->{namespace}; +} + +################################################################################ +# Returns 'Fcm::Config' +sub get_source { + my ($self) = @_; + return 'Fcm::Config'; +} + +################################################################################ +# Loads revision keywords from Fcm::Config to $entries +sub load_to { + my ($self, $entries) = @_; + my $load_counter = 0; + my $config = $self->get_source()->instance(); + my $rev_keyword_ref = $config->setting( + qw/URL_REVISION/, + uc($self->get_namespace()), + ); + if ($rev_keyword_ref) { + for my $key (keys(%{$rev_keyword_ref})) { + $entries->add_entry($key, $rev_keyword_ref->{$key}); + $load_counter++; + } + } + return ($config->is_initialising() ? 0 : defined($load_counter)); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Loader::Config::Revision + +=head1 SYNOPSIS + + $loader = Fcm::Keyword::Loader::Config::Revision->new({namespace => $name}); + $loader->load_to($entries); + +=head1 DESCRIPTION + +Loads revision keywords from L<Fcm::Config|Fcm::Config> into a +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object containing +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> objects. + +=head1 METHODS + +=over 4 + +=item C<new({namespace =E<gt> $namespace})> + +Constructor. The argument $namespace is the namespace where the revision +keywords belong. + +=item get_namespace() + +Returns the namespace where the revision keywords belong. + +=item get_source() + +Returns the string "L<Fcm::Config|Fcm::Config>". + +=item load_to($entries) + +Loads revision keywords in the namespace given by C<$self-E<gt>get_namespace()> +from L<Fcm::Config|Fcm::Config> to $entries. Returns true on success. (However, +if L<Fcm::Config|Fcm::Config> is initialising, returns false to force a reload +next time.) + +=back + +=head1 SEE ALSO + +L<Fcm::Config|Fcm::Config>, +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location>, +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader>, +L<Fcm::Keyword::Loader::Config::Location|Fcm::Keyword::Loader::Config::Location> +L<Fcm::Keyword::Loader::VC::Revision|Fcm::Keyword::Loader::VC::Revision> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/VC/Revision.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/VC/Revision.pm new file mode 100644 index 0000000..9dfda07 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Keyword/Loader/VC/Revision.pm @@ -0,0 +1,103 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Keyword::Loader::VC::Revision; + +use Fcm::Util qw{run_command}; + +sub new { + my ($class, $args_ref) = @_; + return bless({%{$args_ref}}, $class); +} + +################################################################################ +# Returns the VC location where revision keywords will be loaded from +sub get_source { + my ($self) = @_; + return $self->{source}; +} + +################################################################################ +# Loads revision keywords from $self->get_source() to $entries +sub load_to { + my ($self, $entries) = @_; + my @lines = run_command( + [qw{svn pg fcm:revision}, $self->get_source()], + DEVNULL => 1, + ERROR => 'ignore', + METHOD => 'qx', + ); + my $load_counter = 0; + for my $line (@lines) { + chomp($line); + my ($key, $value) = split(qr{\s+ = \s+}xms, $line); + if ($key && $value) { + $entries->add_entry($key, $value); + $load_counter++; + } + } + return defined($load_counter); +} + +1; +__END__ + +=head1 NAME + +Fcm::Keyword::Loader::VC::Revision + +=head1 SYNOPSIS + + $loader = Fcm::Keyword::Loader::VC::Revision->new({source => $source}); + $loader->load_to($entries); + +=head1 DESCRIPTION + +Loads revision keywords from a VC location into a +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries> object containing +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry> objects. + +=head1 METHODS + +=over 4 + +=item C<new({source =E<gt> $source})> + +Constructor. The argument $source is the VC location from which revision +keywords will be loaded from. + +=item get_source() + +Returns the source VC location from which revision keywords will be loaded +from. + +=item load_to($entries) + +Loads revision keywords from C<$self-E<gt>get_source()> to $entries. + +=back + +=head1 TO DO + +Abstract away the call to the VC system, which assumes the Subversion shell +client at the moment. + +=head1 SEE ALSO + +L<Fcm::Keyword|Fcm::Keyword>, +L<Fcm::Keyword::Entries|Fcm::Keyword::Entries>, +L<Fcm::Keyword::Entry|Fcm::Keyword::Entry>, +L<Fcm::Keyword::Entry::Location|Fcm::Keyword::Entry::Location>, +L<Fcm::Keyword::Loader|Fcm::Keyword::Loader>, +L<Fcm::Keyword::Loader::Config::Revision|Fcm::Keyword::Loader::Config::Revision> + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ReposBranch.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ReposBranch.pm new file mode 100644 index 0000000..c3a8e4c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/ReposBranch.pm @@ -0,0 +1,506 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::ReposBranch +# +# DESCRIPTION +# This class contains methods for gathering information for a repository +# branch. It currently supports Subversion repository and local user +# directory. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use warnings; +use strict; + +package Fcm::ReposBranch; +use base qw{Fcm::Base}; + +use Fcm::CfgLine; +use Fcm::Keyword; +use Fcm::Util qw{expand_tilde is_url run_command w_report}; +use File::Basename qw{dirname}; +use File::Find qw{find}; +use File::Spec; + +# List of scalar property methods for this class +my @scalar_properties = ( + 'package', # package name of which this repository belongs + 'repos', # repository branch root URL/path + 'revision', # the revision of this branch + 'tag', # "tag" name of this branch of the repository + 'type', # repository type +); + +# List of hash property methods for this class +my @hash_properties = ( + 'dirs', # list of non-recursive directories in this branch + 'expdirs', # list of recursive directories in this branch +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::ReposBranch->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::ReposBranch class. See +# @scalar_properties above for allowed list of properties in the constructor. +# (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + $self->{$_} = {} for (@hash_properties); + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + return $self->{$name}; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %hash = %{ $obj->X () }; +# $obj->X (\%hash); +# +# $value = $obj->X ($index); +# $obj->X ($index, $value); +# +# DESCRIPTION +# Details of these properties are explained in @hash_properties. +# +# If no argument is set, this method returns a hash containing a list of +# objects. If an argument is set and it is a reference to a hash, the objects +# are replaced by the the specified hash. +# +# If a scalar argument is specified, this method returns a reference to an +# object, if the indexed object exists or undef if the indexed object does +# not exist. If a second argument is set, the $index element of the hash will +# be set to the value of the argument. +# ------------------------------------------------------------------------------ + +for my $name (@hash_properties) { + no strict 'refs'; + + *$name = sub { + my ($self, $arg1, $arg2) = @_; + + # Ensure property is defined as a reference to a hash + $self->{$name} = {} if not defined ($self->{$name}); + + # Argument 1 can be a reference to a hash or a scalar index + my ($index, %hash); + + if (defined $arg1) { + if (ref ($arg1) eq 'HASH') { + %hash = %$arg1; + + } else { + $index = $arg1; + } + } + + if (defined $index) { + # A scalar index is defined, set and/or return the value of an element + $self->{$name}{$index} = $arg2 if defined $arg2; + + return ( + exists $self->{$name}{$index} ? $self->{$name}{$index} : undef + ); + + } else { + # A scalar index is not defined, set and/or return the hash + $self->{$name} = \%hash if defined $arg1; + return $self->{$name}; + } + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_revision; +# +# DESCRIPTION +# This method expands the revision keywords of the current branch to a +# revision number. It returns true on success. +# ------------------------------------------------------------------------------ + +sub expand_revision { + my $self = shift; + + my $rc = 1; + if ($self->type eq 'svn') { + # Expand revision keyword + my $rev = (Fcm::Keyword::expand($self->repos(), $self->revision()))[1]; + + # Get last changed revision of the specified revision + my $info_ref = $self->_svn_info($self->repos(), $rev); + if (!defined($info_ref->{'Revision'})) { + my $url = $self->repos() . ($rev ? '@' . $rev : q{}); + w_report("ERROR: $url: not a valid URL\n"); + return 0; + } + my $lc_rev = $info_ref->{'Last Changed Rev'}; + $rev = $info_ref->{'Revision'}; + + # Print info if specified revision is not the last commit revision + if (uc($self->revision()) ne 'HEAD' && $lc_rev != $rev) { + my $message = $self->repos . '@' . $rev . ': last changed at [' . + $lc_rev . '].'; + if ($self->setting ('EXT_REVMATCH') and uc ($self->revision) ne 'HEAD') { + w_report "ERROR: specified and last changed revisions differ:\n", + ' ', $message, "\n"; + $rc = 0; + + } else { + print 'INFO: ', $message, "\n"; + } + } + + if ($self->verbose > 1 and uc ($self->revision) ne 'HEAD') { + # See if there is a later change of the branch at the HEAD + my $head_lc_rev = $self->_svn_info($self->repos())->{'Last Changed Rev'}; + + if (defined($head_lc_rev) && $head_lc_rev != $lc_rev) { + # Ensure that this is the same branch by checking its history + my @lines = &run_command ( + [qw/svn log -q --incremental -r/, $lc_rev, $self->repos . '@HEAD'], + METHOD => 'qx', TIME => $self->verbose > 2, + ); + + print 'INFO: ', $self->repos, '@', $rev, + ': newest commit at [', $head_lc_rev, '].', "\n" + if @lines; + } + } + + $self->revision ($rev) if $rev ne $self->revision; + + } elsif ($self->type eq 'user') { + 1; # Do nothing + + } else { + w_report 'ERROR: ', $self->repos, ': repository type "', $self->type, + '" not supported.'; + $rc = 0; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_path; +# +# DESCRIPTION +# This method expands the relative path names of sub-directories to full +# path names. It returns true on success. +# ------------------------------------------------------------------------------ + +sub expand_path { + my $self = shift; + + my $rc = 1; + if ($self->type eq 'svn') { + # SVN repository + # Do nothing unless there is a declared repository for this branch + return unless $self->repos; + + # Remove trailing / + my $repos = $self->repos; + $self->repos ($repos) if $repos =~ s#/+$##; + + # Consider all declared (expandable) sub-directories + for my $name (qw/dirs expdirs/) { + for my $dir (keys %{ $self->$name }) { + # Do nothing if declared sub-directory is quoted as a full URL + next if &is_url ($self->$name ($dir)); + + # Expand sub-directory to full URL + $self->$name ($dir, $self->repos . ( + $self->$name ($dir) ? ('/' . $self->$name ($dir)) : '' + )); + } + } + # Note: "catfile" cannot be used in the above statement because it has + # the tendency of removing a slash from double slashes. + + } elsif ($self->type eq 'user') { + # Local user directories + + # Expand leading ~ for all declared (expandable) sub-directories + for my $name (qw/dirs expdirs/) { + for my $dir (keys %{ $self->$name }) { + $self->$name ($dir, expand_tilde $self->$name ($dir)); + } + } + + # A top directory for the source is declared + if ($self->repos) { + # Expand leading ~ for the top directory + $self->repos (expand_tilde $self->repos); + + # Get the root directory of the file system + my $rootdir = File::Spec->rootdir (); + + # Expand top directory to absolute path, if necessary + $self->repos (File::Spec->rel2abs ($self->repos)) + if $self->repos !~ m/^$rootdir/; + + # Remove trailing / + my $repos = $self->repos; + $self->repos ($repos) if $repos =~ s#/+$##; + + # Consider all declared (expandable) sub-directories + for my $name (qw/dirs expdirs/) { + for my $dir (keys %{ $self->$name }) { + # Do nothing if declared sub-directory is quoted as a full path + next if $self->$name ($dir) =~ m#^$rootdir#; + + # Expand sub-directory to full path + $self->$name ( + $dir, $self->$name ($dir) + ? File::Spec->catfile ($self->repos, $self->$name ($dir)) + : $self->repos + ); + } + } + } + + } else { + w_report 'ERROR: ', $self->repos, ': repository type "', $self->type, + '" not supported.'; + $rc = 0; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->expand_all(); +# +# DESCRIPTION +# This method searches the expandable source directories recursively for +# source directories containing regular files. The namespaces and the locators +# of these sub-directories are then added to the source directory hash table. +# Returns true on success. +# ------------------------------------------------------------------------------ + +sub expand_all { + my ($self) = @_; + my %finder_of = ( + user => sub { + my ($root_locator) = @_; + my %ns_of; + my $wanted = sub { + my $base_name = $_; + my $path = $File::Find::name; + if (-f $path && -r $path && !-l $path) { + my $dir_path = dirname($path); + my $rel_dir_path = File::Spec->abs2rel($dir_path, $root_locator); + if (!exists($ns_of{$dir_path})) { + $ns_of{$dir_path} = [File::Spec->splitdir($rel_dir_path)]; + } + } + }; + find($wanted, $root_locator); + return \%ns_of; + }, + svn => sub { + my ($root_locator) = @_; + my $runner = sub { + map {chomp($_); $_} run_command( + ['svn', @_, '-R', join('@', $root_locator, $self->revision())], + METHOD => 'qx', TIME => $self->config()->verbose() > 2, + ); + }; + # FIXME: check for symlink switched off due to "svn pg" being very slow + #my %symlink_in + # = map {($_ =~ qr{\A(.+)\s-\s(\*)\z}xms)} ($runner->(qw{pg svn:special})); + #my @locators + # = grep {$_ !~ qr{/\z}xms && !$symlink_in{$_}} ($runner->('ls')); + my @locators = grep {$_ !~ qr{/\z}xms} ($runner->('ls')); + my %ns_of; + for my $locator (@locators) { + my ($rel_dir_locator) = $locator =~ qr{\A(.*)/[^/]+\z}xms; # dirname + $rel_dir_locator ||= q{}; + my $dir_locator = join(q{/}, $root_locator, $rel_dir_locator); + if (!exists($ns_of{$dir_locator})) { + $ns_of{$dir_locator} = [split(q{/}, $rel_dir_locator)]; + } + } + return \%ns_of; + }, + ); + + if (!defined($finder_of{$self->type()})) { + w_report(sprintf( + qq{ERROR: %s: resource type "%s" not supported}, + $self->repos(), + $self->type(), + )); + return; + } + while (my ($root_ns, $root_locator) = each(%{$self->expdirs()})) { + my @root_ns_list = split(qr{$Fcm::Config::DELIMITER}xms, $root_ns); + my $ns_hash_ref = $finder_of{$self->type()}->($root_locator); + while (my ($dir_path, $ns_list_ref) = each(%{$ns_hash_ref})) { + if (!grep {$_ =~ qr{\A\.}xms || $_ =~ qr{~\z}xms} @{$ns_list_ref}) { + my $ns = join($Fcm::Config::DELIMITER, @root_ns_list, @{$ns_list_ref}); + $self->dirs($ns, $dir_path); + } + } + } + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $n = $obj->add_base_dirs ($base); +# +# DESCRIPTION +# Add a list of source directories to the current branch based on the set +# provided by $base, which must be a reference to a Fcm::ReposBranch +# instance. It returns the total number of used sub-directories in the +# current repositories. +# ------------------------------------------------------------------------------ + +sub add_base_dirs { + my $self = shift; + my $base = shift; + + my %base_dirs = %{ $base->dirs }; + + for my $key (keys %base_dirs) { + # Remove repository root from base directories + if ($base_dirs{$key} eq $base->repos) { + $base_dirs{$key} = ''; + + } else { + $base_dirs{$key} = substr $base_dirs{$key}, length ($base->repos) + 1; + } + + # Append base directories to current repository root + $self->dirs ($key, $base_dirs{$key}); + } + + # Expand relative path names of sub-directories + $self->expand_path; + + return scalar keys %{ $self->dirs }; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @cfglines = $obj->to_cfglines (); +# +# DESCRIPTION +# This method returns a list of configuration lines for the current branch. +# ------------------------------------------------------------------------------ + +sub to_cfglines { + my ($self) = @_; + my @return = (); + + my $suffix = $self->package . $Fcm::Config::DELIMITER . $self->tag; + push @return, Fcm::CfgLine->new ( + label => $self->cfglabel ('REPOS') . $Fcm::Config::DELIMITER . $suffix, + value => $self->repos, + ) if $self->repos; + + push @return, Fcm::CfgLine->new ( + label => $self->cfglabel ('REVISION') . $Fcm::Config::DELIMITER . $suffix, + value => $self->revision, + ) if $self->revision; + + for my $key (sort keys %{ $self->dirs }) { + my $value = $self->dirs ($key); + + # Use relative path where possible + if ($self->repos) { + if ($value eq $self->repos) { + $value = ''; + + } elsif (index ($value, $self->repos) == 0) { + $value = substr ($value, length ($self->repos) + 1); + } + } + + # Use top package name where possible + my $dsuffix = $key . $Fcm::Config::DELIMITER . $self->tag; + $dsuffix = $suffix if $value ne $self->dirs ($key) and $key eq join ( + $Fcm::Config::DELIMITER, $self->package, File::Spec->splitdir ($value) + ); + + push @return, Fcm::CfgLine->new ( + label => $self->cfglabel ('DIRS') . $Fcm::Config::DELIMITER . $dsuffix, + value => $value, + ); + } + + push @return, Fcm::CfgLine->new (); + + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# my $hash_ref = $self->_svn_info($url[, $rev]); +# +# DESCRIPTION +# Executes "svn info" and returns each field in a hash. +# ------------------------------------------------------------------------------ +sub _svn_info { + my ($self, $url, $rev) = @_; + return { + map { + chomp(); + my ($key, $value) = split(qr{\s*:\s*}xms, $_, 2); + $key ? ($key, $value) : (); + } run_command( + [qw{svn info}, ($rev ? ('-r', $rev, join('@', $url, $rev)) : $url)], + DEVNULL => 1, METHOD => 'qx', TIME => $self->verbose() > 2, + ) + }; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/SrcDirLayer.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/SrcDirLayer.pm new file mode 100644 index 0000000..bc09fe7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/SrcDirLayer.pm @@ -0,0 +1,264 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::SrcDirLayer +# +# DESCRIPTION +# This class contains methods to manipulate the extract of a source +# directory from a branch of a (Subversion) repository. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use warnings; +use strict; + +package Fcm::SrcDirLayer; +use base qw{Fcm::Base}; + +use Fcm::Util qw{run_command e_report w_report}; +use File::Basename qw{dirname}; +use File::Path qw{mkpath}; +use File::Spec; + +# List of property methods for this class +my @scalar_properties = ( + 'cachedir', # cache directory for this directory branch + 'commit', # revision at which the source directory was changed + 'extracted', # is this branch already extracted? + 'files', # list of source files in this directory branch + 'location', # location of the source directory in the branch + 'name', # sub-package name of the source directory + 'package', # top level package name of which the current repository belongs + 'reposroot', # repository root URL + 'revision', # revision of the repository branch + 'tag', # package/revision tag of the current repository branch + 'type', # type of the repository branch ("svn" or "user") +); + +my %ERR_MESS_OF = ( + CACHE_WRITE => '%s: cannot write to cache', + SYMLINK => '%s/%s: ignore symbolic link', + VC_TYPE => '%s: repository type not supported', +); + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $obj = Fcm::SrcDirLayer->new (%args); +# +# DESCRIPTION +# This method constructs a new instance of the Fcm::SrcDirLayer class. See +# above for allowed list of properties. (KEYS should be in uppercase.) +# ------------------------------------------------------------------------------ + +sub new { + my $this = shift; + my %args = @_; + my $class = ref $this || $this; + + my $self = Fcm::Base->new (%args); + + for (@scalar_properties) { + $self->{$_} = exists $args{uc ($_)} ? $args{uc ($_)} : undef; + } + + bless $self, $class; + return $self; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $value = $obj->X; +# $obj->X ($value); +# +# DESCRIPTION +# Details of these properties are explained in @scalar_properties. +# ------------------------------------------------------------------------------ + +for my $name (@scalar_properties) { + no strict 'refs'; + + *$name = sub { + my $self = shift; + + # Argument specified, set property to specified argument + if (@_) { + $self->{$name} = $_[0]; + } + + # Default value for property + if (not defined $self->{$name}) { + if ($name eq 'files') { + # Reference to an array + $self->{$name} = []; + } + } + + return $self->{$name}; + } +} + +# Handles error/warning events. +sub _err { + my ($key, $args_ref, $warn_only) = @_; + my $reporter = $warn_only ? \&w_report : \&e_report; + $args_ref ||= []; + $reporter->(sprintf($ERR_MESS_OF{$key} . ".\n", @{$args_ref})); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $dir = $obj->localdir; +# +# DESCRIPTION +# This method returns the user or cache directory for the current revision +# of the repository branch. +# ------------------------------------------------------------------------------ + +sub localdir { + my $self = shift; + + return $self->user ? $self->location : $self->cachedir; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $user = $obj->user; +# +# DESCRIPTION +# This method returns the string "user" if the current source directory +# branch is a local directory. Otherwise, it returns "undef". +# ------------------------------------------------------------------------------ + +sub user { + my $self = shift; + + return $self->type eq 'user' ? 'user' : undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rev = $obj->get_commit; +# +# DESCRIPTION +# If the current repository type is "svn", this method attempts to obtain +# the revision in which the branch is last committed. On a successful +# operation, it returns this revision number. Otherwise, it returns +# "undef". +# ------------------------------------------------------------------------------ + +sub get_commit { + my $self = shift; + + if ($self->type eq 'svn') { + # Execute the "svn info" command + my @lines = &run_command ( + [qw/svn info -r/, $self->revision, $self->location . '@' . $self->revision], + METHOD => 'qx', TIME => $self->config->verbose > 2, + ); + + my $rev; + for (@lines) { + if (/^Last\s+Changed\s+Rev\s*:\s*(\d+)/i) { + $rev = $1; + last; + } + } + + # Commit revision of this source directory + $self->commit ($rev); + + return $self->commit; + + } elsif ($self->type eq 'user') { + return; + + } else { + _err('VC_TYPE', [$self->type()]); + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = $obj->update_cache; +# +# DESCRIPTION +# If the current repository type is "svn", this method attempts to extract +# the current revision source directory from the current branch from the +# repository, sending the output to the cache directory. It returns true on +# a successful operation, or false if the repository is not of type "svn". +# ------------------------------------------------------------------------------ + +sub update_cache { + my $self = shift; + + return unless $self->cachedir; + + # Create cache extract destination, if necessary + my $dirname = dirname $self->cachedir; + mkpath($dirname); + + if (!-w $dirname) { + _err('CACHE_WRITE', [$dirname]); + } + + if ($self->type eq 'svn') { + # Set up the extract command, "svn export --force -q -N" + my @command = ( + qw/svn export --force -q -N/, + $self->location . '@' . $self->revision, + $self->cachedir, + ); + + &run_command (\@command, TIME => $self->config->verbose > 2); + + } elsif ($self->type eq 'user') { + return; + + } else { + _err('VC_TYPE', [$self->type()]); + } + + return 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @files = $obj->get_files(); +# +# DESCRIPTION +# This method returns a list of file base names in the (cache of) this source +# directory in the current branch. +# ------------------------------------------------------------------------------ + +sub get_files { + my ($self) = @_; + opendir(my $dir, $self->localdir()) + || die($self->localdir(), ': cannot read directory'); + my @base_names = (); + BASE_NAME: + while (my $base_name = readdir($dir)) { + if ($base_name =~ qr{\A\.}xms || $base_name =~ qr{~\z}xms) { + next BASE_NAME; + } + my $path = File::Spec->catfile($self->localdir(), $base_name); + if (-d $path) { + next BASE_NAME; + } + if (-l $path) { + _err('SYMLINK', [$self->location(), $base_name], 1); + next BASE_NAME; + } + push(@base_names, $base_name); + } + closedir($dir); + $self->files(\@base_names); + return @base_names; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Timer.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Timer.pm new file mode 100644 index 0000000..3ee7202 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Timer.pm @@ -0,0 +1,72 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Timer +# +# DESCRIPTION +# This is a package of timer utility used by the FCM command. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +package Fcm::Timer; + +# Standard pragma +use warnings; +use strict; + +# Exports +our (@ISA, @EXPORT, @EXPORT_OK); + +sub timestamp_command; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(timestamp_command); + +# ------------------------------------------------------------------------------ + +# Module level variables +my %cmd_start_time = (); # Command start time, (key = command, value = time) + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &Fcm::Timer::timestamp_command ($command[, $status]); +# +# DESCRIPTION +# This function returns a string adding to $command a prefix according the +# value of $status. If $status is not specified or does not match the word +# "end", the status is assumed to be "start". At "start", the prefix will +# contain the current timestamp. If $status is the word "end", the prefix +# will contain the total time taken since this function was called with the +# same $command at the "start" status. +# ------------------------------------------------------------------------------ + +sub timestamp_command { + (my $command, my $status) = @_; + + my $prefix; + if ($status and $status =~ /end/i) { + # Status is "end", insert time taken + my $lapse = time () - $cmd_start_time{$command}; + $prefix = sprintf "# Time taken: %12d s=> ", $lapse; + + } else { + # Status is "start", insert time stamp + $cmd_start_time{$command} = time; + + (my $sec, my $min, my $hour, my $mday, my $mon, my $year) = localtime; + $prefix = sprintf "# Start: %04d-%02d-%02d %02d:%02d:%02d=> ", + $year + 1900, $mon + 1, $mday, $hour, $min, $sec; + } + + return $prefix . $command . "\n"; +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Util.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Util.pm new file mode 100644 index 0000000..c833f49 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Util.pm @@ -0,0 +1,552 @@ +# ------------------------------------------------------------------------------ +# NAME +# Fcm::Util +# +# DESCRIPTION +# This is a package of misc utilities used by the FCM command. +# +# COPYRIGHT +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use warnings; +use strict; + +package Fcm::Util; +require Exporter; +our @ISA = qw{Exporter}; + +sub expand_tilde; +sub e_report; +sub find_file_in_path; +sub get_command_string; +sub get_rev_of_wc; +sub get_url_of_wc; +sub get_url_peg_of_wc; +sub get_wct; +sub is_url; +sub is_wc; +sub print_command; +sub run_command; +sub svn_date; +sub tidy_url; +sub touch_file; +sub w_report; + +our @EXPORT = qw{ + expand_tilde + e_report + find_file_in_path + get_command_string + get_rev_of_wc + get_url_of_wc + get_url_peg_of_wc + get_wct + is_url + is_wc + print_command + run_command + svn_date + tidy_url + touch_file + w_report +}; + +# Standard modules +use Carp; +use Cwd; +use File::Basename; +use File::Find; +use File::Path; +use File::Spec; +use POSIX qw{strftime SIGINT SIGKILL SIGTERM WEXITSTATUS WIFSIGNALED WTERMSIG}; + +# FCM component modules +use Fcm::Timer; + +# ------------------------------------------------------------------------------ + +# Module level variables +my %svn_info = (); # "svn info" log, (key1 = path, + # key2 = URL, Revision, Last Changed Rev) + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# %srcdir = &Fcm::Util::find_file_in_path ($file, \@path); +# +# DESCRIPTION +# Search $file in @path. Returns the full path of the $file if it is found +# in @path. Returns "undef" if $file is not found in @path. +# ------------------------------------------------------------------------------ + +sub find_file_in_path { + my ($file, $path) = @_; + + for my $dir (@$path) { + my $full_file = File::Spec->catfile ($dir, $file); + return $full_file if -e $full_file; + } + + return undef; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $expanded_path = &Fcm::Util::expand_tilde ($path); +# +# DESCRIPTION +# Returns an expanded path if $path is a path that begins with a tilde (~). +# ------------------------------------------------------------------------------ + +sub expand_tilde { + my $file = $_[0]; + + $file =~ s#^~([^/]*)#$1 ? (getpwnam $1)[7] : ($ENV{HOME} || $ENV{LOGDIR})#ex; + + # Expand . and .. + while ($file =~ s#/+\.(?:/+|$)#/#g) {next} + while ($file =~ s#/+[^/]+/+\.\.(?:/+|$)#/#g) {next} + + # Remove trailing / + $file =~ s#/*$##; + + return $file; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $rc = &Fcm::Util::touch_file ($file); +# +# DESCRIPTION +# Touch $file if it exists. Create $file if it does not exist. Return 1 for +# success or 0 otherwise. +# ------------------------------------------------------------------------------ + +sub touch_file { + my $file = $_[0]; + my $rc = 1; + + if (-e $file) { + my $now = time; + $rc = utime $now, $now, $file; + + } else { + mkpath dirname ($file) unless -d dirname ($file); + + $rc = open FILE, '>', $file; + $rc = close FILE if $rc; + } + + return $rc; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = &is_wc ([$path]); +# +# DESCRIPTION +# Returns true if current working directory (or $path) is a Subversion +# working copy. +# ------------------------------------------------------------------------------ + +sub is_wc { + my $path = @_ ? $_[0] : cwd (); + + if (-d $path) { + return (-e File::Spec->catfile ($path, qw/.svn format/)) ? 1 : 0; + + } elsif (-f $path) { + return (-e File::Spec->catfile (dirname ($path), qw/.svn format/)) ? 1 : 0; + + } else { + return 0; + } +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $flag = &is_url ($url); +# +# DESCRIPTION +# Returns true if $url is a URL. +# ------------------------------------------------------------------------------ + +sub is_url { + # This should handle URL beginning with svn://, http:// and svn+ssh:// + return ($_[0] =~ m#^[\+\w]+://#); +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $url = tidy_url($url); +# +# DESCRIPTION +# Returns a tidied version of $url by removing . and .. in the path. +# ------------------------------------------------------------------------------ + +sub tidy_url { + my ($url) = @_; + if (!is_url($url)) { + return $url; + } + my $DOT_PATTERN = qr{/+ \. (?:/+|(@|\z))}xms; + my $DOT_DOT_PATTERN = qr{/+ [^/]+ /+ \.\. (?:/+|(@|\z))}xms; + my $TRAILING_SLASH_PATTERN = qr{([^/]+) /* (@|\z)}xms; + my $RIGHT_EVAL = q{'/' . ($1 ? $1 : '')}; + DOT: + while ($url =~ s{$DOT_PATTERN}{$RIGHT_EVAL}eegxms) { + next DOT; + } + DOT_DOT: + while ($url =~ s{$DOT_DOT_PATTERN}{$RIGHT_EVAL}eegxms) { + next DOT_DOT; + } + $url =~ s{$TRAILING_SLASH_PATTERN}{$1$2}xms; + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_wct ([$dir]); +# +# DESCRIPTION +# If current working directory (or $dir) is a Subversion working copy, +# returns the top directory of this working copy; otherwise returns an empty +# string. +# ------------------------------------------------------------------------------ + +sub get_wct { + my $dir = @_ ? $_[0] : cwd (); + + return '' if not &is_wc ($dir); + + my $updir = dirname $dir; + while (&is_wc ($updir)) { + $dir = $updir; + $updir = dirname $dir; + last if $updir eq $dir; + } + + return $dir; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_url_of_wc ([$path[, $refresh]]); +# +# DESCRIPTION +# If current working directory (or $path) is a Subversion working copy, +# returns the URL of the associated Subversion repository; otherwise returns +# an empty string. If $refresh is specified, do not use the cached +# information. +# ------------------------------------------------------------------------------ + +sub get_url_of_wc { + my $path = @_ ? $_[0] : cwd (); + my $refresh = exists $_[1] ? $_[1] : 0; + my $url = ''; + + if (&is_wc ($path)) { + delete $svn_info{$path} if $refresh; + &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; + $url = $svn_info{$path}{URL}; + } + + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_url_peg_of_wc ([$path[, $refresh]]); +# +# DESCRIPTION +# If current working directory (or $path) is a Subversion working copy, +# returns the URL@REV of the associated Subversion repository; otherwise +# returns an empty string. If $refresh is specified, do not use the cached +# information. +# ------------------------------------------------------------------------------ + +sub get_url_peg_of_wc { + my $path = @_ ? $_[0] : cwd (); + my $refresh = exists $_[1] ? $_[1] : 0; + my $url = ''; + + if (&is_wc ($path)) { + delete $svn_info{$path} if $refresh; + &_invoke_svn_info (PATH => $path) unless exists $svn_info{$path}; + $url = $svn_info{$path}{URL} . '@' . $svn_info{$path}{Revision}; + } + + return $url; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &_invoke_svn_info (PATH => $path); +# +# DESCRIPTION +# The function is internal to this module. It invokes "svn info" on $path to +# gather information on URL, Revision and Last Changed Rev. The information +# is stored in a hash table at the module level, so that the information can +# be re-used. +# ------------------------------------------------------------------------------ + +sub _invoke_svn_info { + my %args = @_; + my $path = $args{PATH}; + my $cfg = Fcm::Config->instance(); + + return if exists $svn_info{$path}; + + # Invoke "svn info" command + my @info = &run_command ( + [qw/svn info/, $path], + PRINT => $cfg->verbose > 2, METHOD => 'qx', DEVNULL => 1, ERROR => 'ignore', + ); + for (@info) { + chomp; + + if (/^(URL|Revision|Last Changed Rev):\s*(.+)$/) { + $svn_info{$path}{$1} = $2; + } + } + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $string = &get_command_string ($cmd); +# $string = &get_command_string (\@cmd); +# +# DESCRIPTION +# The function returns a string by converting the list in @cmd or the scalar +# $cmd to a form, where it can be executed as a shell command. +# ------------------------------------------------------------------------------ + +sub get_command_string { + my $cmd = $_[0]; + my $return = ''; + + if (ref ($cmd) and ref ($cmd) eq 'ARRAY') { + # $cmd is a reference to an array + + # Print each argument + for my $i (0 .. @{ $cmd } - 1) { + my $arg = $cmd->[$i]; + + $arg =~ s/./*/g if $i > 0 and $cmd->[$i - 1] eq '--password'; + + if ($arg =~ /[\s'"*?]/) { + # Argument contains a space, quote it + if (index ($arg, "'") >= 0) { + # Argument contains an apostrophe, quote it with double quotes + $return .= ($i > 0 ? ' ' : '') . '"' . $arg . '"'; + + } else { + # Otherwise, quote argument with apostrophes + $return .= ($i > 0 ? ' ' : '') . "'" . $arg . "'"; + } + + } else { + # Argument does not contain a space, just print it + $return .= ($i > 0 ? ' ' : '') . ($arg eq '' ? "''" : $arg); + } + } + + } else { + # $cmd is a scalar, just print it "as is" + $return = $cmd; + } + + return $return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &print_command ($cmd); +# &print_command (\@cmd); +# +# DESCRIPTION +# The function prints the list in @cmd or the scalar $cmd, as it would be +# executed by the shell. +# ------------------------------------------------------------------------------ + +sub print_command { + my $cmd = $_[0]; + + print '=> ', &get_command_string ($cmd) , "\n"; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# @return = &run_command (\@cmd, <OPTIONS>); +# @return = &run_command ($cmd , <OPTIONS>); +# +# DESCRIPTION +# This function executes the command in the list @cmd or in the scalar $cmd. +# The remaining are optional arguments in a hash table. Valid options are +# listed below. If the command is run using "qx", the function returns the +# standard output from the command. If the command is run using "system", the +# function returns true on success. By default, the function dies on failure. +# +# OPTIONS +# METHOD => $method - this can be "system", "exec" or "qx". This determines +# how the command will be executed. If not set, the +# default is to run the command with "system". +# PRINT => 1 - if set, print the command before executing it. +# ERROR => $flag - this should only be set if METHOD is set to "system" +# or "qx". The $flag can be "die" (default), "warn" or +# "ignore". If set to "die", the function dies on error. +# If set to "warn", the function issues a warning on +# error, and the function returns false. If set to +# "ignore", the function returns false on error. +# RC => 1 - if set, must be a reference to a scalar, which will be +# set to the return code of the command. +# DEVNULL => 1 - if set, re-direct STDERR to /dev/null before running +# the command. +# TIME => 1 - if set, print the command with a timestamp before +# executing it, and print the time taken when it +# completes. This option supersedes the PRINT option. +# ------------------------------------------------------------------------------ + +sub run_command { + my ($cmd, %input_opt_of) = @_; + my %opt_of = ( + DEVNULL => undef, + ERROR => 'die', + METHOD => 'system', + PRINT => undef, + RC => undef, + TIME => undef, + %input_opt_of, + ); + local($|) = 1; # Make sure STDOUT is flushed before running command + + # Print the command before execution, if necessary + if ($opt_of{TIME}) { + print(timestamp_command(get_command_string($cmd))); + } + elsif ($opt_of{PRINT}) { + print_command($cmd); + } + + # Re-direct STDERR to /dev/null if necessary + if ($opt_of{DEVNULL}) { + no warnings; + open(OLDERR, ">&STDERR") || croak("Cannot dup STDERR ($!), abort"); + use warnings; + open(STDERR, '>', File::Spec->devnull()) + || croak("Cannot redirect STDERR ($!), abort"); + # Make sure the channels are unbuffered + my $select = select(); + select(STDERR); local($|) = 1; + select($select); + } + + my @return = (); + if (ref($cmd) && ref($cmd) eq 'ARRAY') { + # $cmd is an array + my @command = @{$cmd}; + if ($opt_of{METHOD} eq 'qx') { + @return = qx(@command); + } + elsif ($opt_of{METHOD} eq 'exec') { + exec(@command); + } + else { + system(@command); + @return = $? ? () : (1); + } + } + else { + # $cmd is an scalar + if ($opt_of{METHOD} eq 'qx') { + @return = qx($cmd); + } + elsif ($opt_of{METHOD} eq 'exec') { + exec($cmd); + } + else { + system($cmd); + @return = $? ? () : (1); + } + } + my $rc = $?; + + # Put STDERR back to normal, if redirected previously + if ($opt_of{DEVNULL}) { + close(STDERR); + open(STDERR, ">&OLDERR") || croak("Cannot dup STDERR ($!), abort"); + } + + # Print the time taken for command after execution, if necessary + if ($opt_of{TIME}) { + print(timestamp_command(get_command_string($cmd), 'end')); + } + + # Signal and return code + my ($signal, $status) = (WTERMSIG($rc), WEXITSTATUS($rc)); + if (exists($opt_of{RC})) { + ${$opt_of{RC}} = $status; + } + if (WIFSIGNALED($rc) && grep {$signal == $_} (SIGINT, SIGKILL, SIGTERM)) { + croak(sprintf('%s terminated (%d)', get_command_string($cmd), $signal)); + } + if ($status && $opt_of{ERROR} ne 'ignore') { + my $func_ref = $opt_of{ERROR} eq 'warn' ? \&carp : \&croak; + $func_ref->(sprintf('%s failed (%d)', get_command_string($cmd), $status)); + } + return @return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &e_report (@message); +# +# DESCRIPTION +# The function prints @message to STDERR and aborts with a error. +# ------------------------------------------------------------------------------ + +sub e_report { + print STDERR @_, "\n" if @_; + + exit 1; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# &w_report (@message); +# +# DESCRIPTION +# The function prints @message to STDERR and returns. +# ------------------------------------------------------------------------------ + +sub w_report { + print STDERR @_, "\n" if @_; + + return; +} + +# ------------------------------------------------------------------------------ +# SYNOPSIS +# $date = &svn_date ($time); +# +# DESCRIPTION +# The function returns a date, formatted as by Subversion. The argument $time +# is the number of seconds since epoch. +# ------------------------------------------------------------------------------ + +sub svn_date { + my $time = shift; + + return strftime ('%Y-%m-%d %H:%M:%S %z (%a, %d %b %Y)', localtime ($time)); +} + +# ------------------------------------------------------------------------------ + +1; + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Util/ClassLoader.pm b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Util/ClassLoader.pm new file mode 100644 index 0000000..c9b0470 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/lib/Fcm/Util/ClassLoader.pm @@ -0,0 +1,80 @@ +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ +use strict; +use warnings; + +package Fcm::Util::ClassLoader; +use base qw{Exporter}; + +our @EXPORT_OK = qw{load}; + +use Carp qw{croak}; +use Fcm::Exception; + +sub load { + my ($class, $test_method) = @_; + if (!$test_method) { + $test_method = 'new'; + } + if (!UNIVERSAL::can($class, $test_method)) { + eval('require ' . $class); + if ($@) { + croak(Fcm::Exception->new({message => sprintf( + "%s: class loading failed: %s", $class, $@, + )})); + } + } + return $class; +} + +1; +__END__ + +=head1 NAME + +Fcm::ClassLoader + +=head1 SYNOPSIS + + use Fcm::Util::ClassLoader; + $load_ok = Fcm::Util::ClassLoader::load($class); + +=head1 DESCRIPTION + +A wrapper for loading a class dynamically. + +=head1 FUNCTIONS + +=over 4 + +=item load($class,$test_method) + +If $class can call $test_method, returns $class. Otherwise, attempts to +require() $class and returns it. If this fails, croak() with a +L<Fcm::Exception|Fcm::Exception>. + +=item load($class) + +Shorthand for C<load($class, 'new')>. + +=back + +=head1 DIAGNOSTICS + +=over 4 + +=item L<Fcm::Exception|Fcm::Exception> + +The load($class,$test_method) function croak() with this exception if it fails +to load the specified class. + +=back + +=head1 COPYRIGHT + +E<169> Crown copyright Met Office. All rights reserved. + +=cut diff --git a/NEMO_4.0.4_surge/ext/FCM/man/man1/fcm.1 b/NEMO_4.0.4_surge/ext/FCM/man/man1/fcm.1 new file mode 100644 index 0000000..ad5ecea --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/man/man1/fcm.1 @@ -0,0 +1,35 @@ +.\" Process this file with +.\" groff -man -Tascii fcm.1 +.\" +.TH fcm 1 "" "" "User Commands" +.SH NAME +fcm - command line client for the Flexible Configuration Management system +.SH SYNOPSIS +.B fcm +.I command +[ +.I options +] [ +.I args +] +.SH OVERVIEW +.B fcm +is the command line client for code management commands, the extract system and +the build system of the Flexible Configuration Management (FCM) system. +For full detail of the system, please refer to the FCM user guide, which you +should receive with this distribution in both HTML and PDF formats. +.PP +Run "fcm help" to access the built-in tool documentation. +.SH AUTHOR +FCM Team <fcm-team@metoffice.gov.uk>. +Please feedback any bug reports or feature requests to us by e-mail. +.SH COPYRIGHT +British Crown Copyright \(co Met Office. All rights reserved. +.PP +You can use this release of +.B FCM +freely under the terms of the FCM LICENSE, +which you should receive with this distribution. +.SH SEE ALSO +.BR svn (1), +.BR perl (1) diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran-extract-interface-result.f90 b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran-extract-interface-result.f90 new file mode 100644 index 0000000..0ca0006 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran-extract-interface-result.f90 @@ -0,0 +1,70 @@ +interface +logical function func_simple() +end function func_simple +logical function func_simple_1() +end function +logical function func_simple_2() +end +pure logical function func_simple_pure() +end function func_simple_pure +recursive pure integer function func_simple_recursive_pure(i) +integer, intent(in) :: i +end function func_simple_recursive_pure +elemental logical function func_simple_elemental() +end function func_simple_elemental +integer(selected_int_kind(0)) function func_with_use_and_args(egg, ham) +use foo +use bar, only:& + & i_am_dim +integer, intent(in) :: egg(i_am_dim) +integer, intent(in) :: ham(i_am_dim, 2) +end function func_with_use_and_args +character(20) function func_with_parameters(egg, ham) +character*(*), parameter :: x_param = '01234567890' +character(*), parameter :: & + y_param & + = '!&!&!&!&!&!' +character(len(x_param)), intent(in) :: egg +character(len(y_param)), intent(in) :: ham +end function func_with_parameters +function func_with_parameters_1(egg, ham) result(r) +integer, parameter :: x_param = 10 +integer z_param +parameter(z_param = 2) +real, intent(in), dimension(x_param) :: egg +integer, intent(in) :: ham +logical :: r(z_param) +end function func_with_parameters_1 +character(10) function func_with_contains(mushroom, tomoato) +character(5) mushroom +character(5) tomoato +end function func_with_contains +Function func_mix_local_and_result(egg, ham, bacon) Result(Breakfast) +Integer, Intent(in) :: egg, ham +Real, Intent(in) :: bacon +Real :: tomato, breakfast +End Function func_mix_local_and_result +subroutine sub_simple() +end subroutine sub_simple +subroutine sub_simple_1() +end subroutine +subroutine sub_simple_2() +end +subroutine sub_simple_3() +end sub& +&routine& +& sub_simple_3 +subroutine sub_with_contains(foo) +character*(len('!"&''&"!')) & + foo +end subroutine sub_with_contains +subroutine sub_with_renamed_import(i_am_dim) +integer, parameter :: d = 2 +complex :: i_am_dim(d) +end subroutine sub_with_renamed_import +subroutine sub_with_external(proc) +external proc +end subroutine sub_with_external +subroutine sub_with_end() +end subroutine sub_with_end +end interface diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran-extract-interface-source.f90 b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran-extract-interface-source.f90 new file mode 100644 index 0000000..6f22252 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran-extract-interface-source.f90 @@ -0,0 +1,181 @@ +! A simple function +logical function func_simple() +func_simple = .true. +end function func_simple + +! A simple function, but with less friendly end +logical function func_simple_1() +func_simple_1 = .true. +end function + +! A simple function, but with even less friendly end +logical function func_simple_2() +func_simple_2 = .true. +end + +! A pure simple function +pure logical function func_simple_pure() +func_simple_pure = .true. +end function func_simple_pure + +! A pure recursive function +recursive pure integer function func_simple_recursive_pure(i) +integer, intent(in) :: i +if (i <= 0) then + func_simple_recursive_pure = i +else + func_simple_recursive_pure = i + func_simple_recursive_pure(i - 1) +end if +end function func_simple_recursive_pure + +! An elemental simple function +elemental logical function func_simple_elemental() +func_simple_elemental = .true. +end function func_simple_elemental + +! A module with nonsense +module bar +type food +integer :: cooking_method +end type food +type organic +integer :: growing_method +end type organic +integer, parameter :: i_am_dim = 10 +end module bar + +! A module with more nonsense +module foo +use bar, only: FOOD +integer :: foo_int +contains +subroutine foo_sub(egg) +integer, parameter :: egg_dim = 10 +type(Food), intent(in) :: egg +write(*, *) egg +end subroutine foo_sub +elemental function foo_func() result(f) +integer :: f +f = 0 +end function +end module foo + +! An function with arguments and module imports +integer(selected_int_kind(0)) function func_with_use_and_args(egg, ham) +use foo +! Deliberate trailing spaces in next line +use bar, only : organic, i_am_dim +implicit none +integer, intent(in) :: egg(i_am_dim) +integer, intent(in) :: ham(i_am_dim, 2) +real bacon +! Deliberate trailing spaces in next line +type( organic ) :: tomato +func_with_use_and_args = egg(1) + ham(1, 1) +end function func_with_use_and_args + +! A function with some parameters +character(20) function func_with_parameters(egg, ham) +implicit none +character*(*), parameter :: x_param = '01234567890' +character(*), parameter :: & ! throw in some comments + y_param & + = '!&!&!&!&!&!' ! how to make life interesting +integer, parameter :: z = 20 +character(len(x_param)), intent(in) :: egg +character(len(y_param)), intent(in) :: ham +func_with_parameters = egg // ham +end function func_with_parameters + +! A function with some parameters, with a result +function func_with_parameters_1(egg, ham) result(r) +implicit none +integer, parameter :: x_param = 10 +integer z_param +parameter(z_param = 2) +real, intent(in), dimension(x_param) :: egg +integer, intent(in) :: ham +logical :: r(z_param) +r(1) = int(egg(1)) + ham > 0 +r(2) = .false. +end function func_with_parameters_1 + +! A function with a contains +character(10) function func_with_contains(mushroom, tomoato) +character(5) mushroom +character(5) tomoato +func_with_contains = func_with_contains_1() +contains +character(10) function func_with_contains_1() +func_with_contains_1 = mushroom // tomoato +end function func_with_contains_1 +end function func_with_contains + +! A function with its result declared after a local in the same statement +Function func_mix_local_and_result(egg, ham, bacon) Result(Breakfast) +Integer, Intent(in) :: egg, ham +Real, Intent(in) :: bacon +Real :: tomato, breakfast +Breakfast = real(egg) + real(ham) + bacon +End Function func_mix_local_and_result + +! A simple subroutine +subroutine sub_simple() +end subroutine sub_simple + +! A simple subroutine, with not so friendly end +subroutine sub_simple_1() +end subroutine + +! A simple subroutine, with even less friendly end +subroutine sub_simple_2() +end + +! A simple subroutine, with funny continuation +subroutine sub_simple_3() +end sub& +&routine& +& sub_simple_3 + +! A subroutine with a few contains +subroutine sub_with_contains(foo) ! " & +! Deliberate trailing spaces in next line +use Bar, only: i_am_dim +character*(len('!"&''&"!')) & ! what a mess! + foo +call sub_with_contains_first() +call sub_with_contains_second() +call sub_with_contains_third() +print*, foo +contains +subroutine sub_with_contains_first() +interface +integer function x() +end function x +end interface +end subroutine sub_with_contains_first +subroutine sub_with_contains_second() +end subroutine +subroutine sub_with_contains_third() +end subroutine +end subroutine sub_with_contains + +! A subroutine with a renamed module import +subroutine sub_with_renamed_import(i_am_dim) +use bar, only: i_am_not_dim => i_am_dim +integer, parameter :: d = 2 +complex :: i_am_dim(d) +print*, i_am_dim +end subroutine sub_with_renamed_import + +! A subroutine with an external argument +subroutine sub_with_external(proc) +external proc +call proc() +end subroutine sub_with_external + +! A subroutine with a variable named "end" +subroutine sub_with_end() +integer :: end +end = 0 +end subroutine sub_with_end diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran.t new file mode 100644 index 0000000..e91b51a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Build/Fortran.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../../../lib"; + +use Test::More (tests => 3); + +if (!caller()) { + main(@ARGV); +} + +sub main { + my $CLASS = 'Fcm::Build::Fortran'; + use_ok($CLASS); + my $util = $CLASS->new(); + isa_ok($util, $CLASS); + test_extract_interface($util); +} + +sub test_extract_interface { + my ($util) = @_; + my $root = ($0 =~ qr{\A(.+)\.t\z}msx)[0]; + my $f90 = $root . '-extract-interface-source.f90'; + my $f90_interface = $root . '-extract-interface-result.f90'; + open(my($handle_for_source), '<', $f90) || die("$f90: $!"); + my @actual_lines = $util->extract_interface($handle_for_source); + close($handle_for_source); + open(my($handle_for_result), '<', $f90_interface) + || die("$f90_interface: $!"); + my @expected_lines = readline($handle_for_result); + close($handle_for_result); + is_deeply(\@actual_lines, \@expected_lines, 'extract_interface'); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI.t new file mode 100755 index 0000000..ae28d0d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI.t @@ -0,0 +1,237 @@ +#!/usr/bin/perl + +use strict; +use warnings; + + +################################################################################ +# A sub-class of Fcm::CLI::Invoker for testing +{ + package TestInvoker; + use base qw{Fcm::CLI::Invoker}; + + our $LATEST_INSTANCE; + + ############################################################################ + # Returns a test attrib + sub get_test_attrib { + my ($self) = @_; + return $self->{test_attrib}; + } + + ############################################################################ + # Invokes the sub-system + sub invoke { + my ($self) = @_; + $LATEST_INSTANCE = $self; + } +} + +use Fcm::CLI::Config; +use Fcm::CLI::Subcommand; +use Test::More (tests => 25); + +main(); + +sub main { + use_ok('Fcm::CLI'); + test_invalid_subcommand(); + test_invoker_not_implemented(); + test_normal_invoke(); + test_help_invoke(); + test_get_invoker_normal(); + test_load_invoker_class(); +} + +################################################################################ +# Tests to ensure that an invalid subcommand results in an exception +sub test_invalid_subcommand { + Fcm::CLI::Config->instance({core_subcommands => [], vc_subcommands => []}); + eval { + local(@ARGV) = ('foo'); + Fcm::CLI::invoke(); + }; + like($@, qr{foo: unknown command}, 'invalid subcommand'); +} + +################################################################################ +# Tests to ensure that an unimplemented invoker results in an exception +sub test_invoker_not_implemented { + Fcm::CLI::Config->instance({ + core_subcommands => [ + Fcm::CLI::Subcommand->new({names => ['foo']}), + Fcm::CLI::Subcommand->new({ + names => ['bar'], invoker_class => 'barley', + }), + ], + vc_subcommands => [], + }); + eval { + local(@ARGV) = ('foo'); + Fcm::CLI::invoke(); + }; + like($@, qr{foo: \s command \s not \s implemented}xms, 'not implemented'); + eval { + local(@ARGV) = ('bar'); + Fcm::CLI::invoke(); + }; + like($@, qr{barley: \s class \s loading \s failed}xms, 'not implemented'); +} + +################################################################################ +# Tests normal usage of invoke +sub test_normal_invoke { + my $prefix = "normal invoke"; + Fcm::CLI::Config->instance({ + core_subcommands => [ + Fcm::CLI::Subcommand->new({ + names => ['foo'], + invoker_class => 'TestInvoker', + invoker_config => {test_attrib => 'test_attrib value'}, + }), + ], + vc_subcommands => [], + }); + ok(!$TestInvoker::LATEST_INSTANCE, "$prefix: invoker not called"); + local(@ARGV) = ('foo', 'bar', 'baz'); + Fcm::CLI::invoke(); + my $invoker = $TestInvoker::LATEST_INSTANCE; + if (!$invoker) { + fail($prefix); + } + else { + is($invoker->get_command(), 'foo', "$prefix: invoker command"); + is_deeply({$invoker->get_options()}, {}, "$prefix: invoker options"); + is_deeply([$invoker->get_arguments()], ['bar', 'baz'], + "$prefix: invoker arguments"); + is($invoker->get_test_attrib(), 'test_attrib value', + "$prefix: invoker test attrib"); + } + $TestInvoker::LATEST_INSTANCE = undef; +} + +################################################################################ +# Tests help usage of invoke +sub test_help_invoke { + my $prefix = "help invoke"; + Fcm::CLI::Config->instance({ + core_subcommands => [ + Fcm::CLI::Subcommand->new({ + names => ['foo'], + invoker_class => 'TestInvoker', + invoker_config => {test_attrib => 'test_attrib value normal'}, + options => [ + Fcm::CLI::Option->new({name => 'foo', is_help => 1}), + ], + }), + Fcm::CLI::Subcommand->new({ + names => [q{}], + invoker_class => 'TestInvoker', + }), + ], + vc_subcommands => [], + }); + ok(!$TestInvoker::LATEST_INSTANCE, "$prefix: invoker not called"); + local(@ARGV) = ('foo', '--foo'); + Fcm::CLI::invoke(); + my $invoker = $TestInvoker::LATEST_INSTANCE; + if (!$invoker) { + fail($prefix); + } + else { + is_deeply([$invoker->get_arguments()], ['foo'], + "$prefix: invoker argument"); + } + $TestInvoker::LATEST_INSTANCE = undef; +} + +################################################################################ +# Tests getting an invoker +sub test_get_invoker_normal { + my $prefix = 'get invoker normal'; + my @options = ( + Fcm::CLI::Option->new({name => 'foo'}), + Fcm::CLI::Option->new({name => 'bar'}), + Fcm::CLI::Option->new({name => 'baz'}), + Fcm::CLI::Option->new({ + name => q{pork}, + delimiter => q{,}, + has_arg => Fcm::CLI::Option->ARRAY_ARG, + }), + ); + my $subcommand = Fcm::CLI::Subcommand->new({options => \@options}); + my %TEST = ( + test1 => { + argv => ['--foo', '--bar', 'egg', 'ham', 'sausage'], + command => 'command', + options => {foo => 1, bar => 1}, + arguments => ['egg', 'ham', 'sausage'], + }, + test2 => { + argv => ['--baz', '--foo', '--bar'], + command => 'test', + options => {foo => 1, bar => 1, baz => 1}, + arguments => [], + }, + test3 => { + argv => ['egg', 'ham', 'sausage'], + command => 'meal', + options => {}, + arguments => ['egg', 'ham', 'sausage'], + }, + test4 => { + argv => ['--pork', 'ham', '--pork', 'sausage'], + command => 'pig', + options => {pork => ['ham', 'sausage']}, + arguments => [], + }, + test5 => { + argv => ['--pork', 'ham,sausage', '--pork', 'bacon', 'liver'], + command => 'pig', + options => {pork => ['ham', 'sausage', 'bacon']}, + arguments => ['liver'], + }, + ); + for my $key (keys(%TEST)) { + local(@ARGV) = @{$TEST{$key}{argv}}; + my ($opts_ref, $args_ref) = Fcm::CLI::_parse_argv_using($subcommand); + is_deeply($opts_ref, $TEST{$key}{options}, + "$prefix $key: get options"); + is_deeply($args_ref, $TEST{$key}{arguments}, + "$prefix $key: get arguments"); + } + my %BAD_TEST = ( + test1 => { + argv => ['--egg', '--bar', 'foo', 'ham', 'sausage'], + }, + test2 => { + argv => ['--foo=egg'], + }, + ); + for my $key (keys(%BAD_TEST)) { + local(@ARGV) = @{$BAD_TEST{$key}{argv}}; + eval { + Fcm::CLI::_parse_argv_using($subcommand); + }; + isa_ok($@, 'Fcm::CLI::Exception', "$prefix $key"); + } +} + +################################################################################ +# Tests loading an invoker with a different class +sub test_load_invoker_class { + my $prefix = 'get invoker class'; + eval { + my $subcommand = Fcm::CLI::Subcommand->new({invoker_class => 'foo'}); + Fcm::CLI::_load_invoker_class_of($subcommand); + }; + isa_ok($@, 'Fcm::Exception', "$prefix"); + + my $invoker_class = 'Fcm::CLI::Invoker::ConfigSystem'; + my $subcommand + = Fcm::CLI::Subcommand->new({invoker_class => $invoker_class}); + my $class = Fcm::CLI::_load_invoker_class_of($subcommand); + is($class, $invoker_class, "$prefix: $invoker_class"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Config.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Config.t new file mode 100755 index 0000000..0f79b00 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Config.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::CLI::Config::Default; +use Fcm::CLI::Subcommand; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Config'; + use_ok($class); + test_get_instance($class); + test_get_subcommand_of_string($class); +} + +################################################################################ +# Tests normal usage of getting an instance +sub test_get_instance { + my ($class) = @_; + my $prefix = 'constructor'; + my $cli_config = $class->instance(); + isa_ok($cli_config, $class, "$prefix"); + is_deeply( + [$cli_config->get_core_subcommands()], + \@Fcm::CLI::Config::Default::CORE_SUBCOMMANDS, + "$prefix: default core", + ); + is_deeply( + [$cli_config->get_vc_subcommands()], + \@Fcm::CLI::Config::Default::VC_SUBCOMMANDS, + "$prefix: default vc", + ); + is_deeply( + [$cli_config->get_subcommands()], + [$cli_config->get_core_subcommands(), $cli_config->get_vc_subcommands()], + "$prefix: default", + ); + is($class->instance(), $cli_config, "$prefix: same instance"); + isnt($class->instance({}), $cli_config, "$prefix: not the same instance"); + my $empty_cli_config = $class->instance({ + core_subcommands => [], + vc_subcommands => [], + }); + is_deeply( + [$empty_cli_config->get_core_subcommands()], + [], + "$prefix: empty core", + ); + is_deeply( + [$empty_cli_config->get_vc_subcommands()], + [], + "$prefix: empty vc", + ); + is_deeply( + [$empty_cli_config->get_subcommands()], + [], + "$prefix: empty", + ); +} + +################################################################################ +# Tests getting a subcommand of a matching string +sub test_get_subcommand_of_string { + my ($class) = @_; + my $prefix = 'get_subcommand_of'; + my $foo_subcommand = Fcm::CLI::Subcommand->new({names => ['food', 'foo']}); + my $bar_subcommand = Fcm::CLI::Subcommand->new({names => ['barley', 'bar']}); + my $cli_config = $class->instance({ + core_subcommands => [$foo_subcommand, $bar_subcommand], + vc_subcommands => [], + }); + for my $key ('food', 'foo') { + is($cli_config->get_subcommand_of($key), $foo_subcommand, + "$prefix: $key"); + } + for my $key ('barley', 'bar') { + is($cli_config->get_subcommand_of($key), $bar_subcommand, + "$prefix: $key"); + } + is($cli_config->get_subcommand_of('baz'), undef, "$prefix: baz"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Config/Default.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Config/Default.t new file mode 100755 index 0000000..e7ed087 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Config/Default.t @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Config::Default'; + use_ok($class); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Exception.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Exception.t new file mode 100755 index 0000000..8e6131c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Exception.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Exception'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $e = $class->new({message => 'message'}); + isa_ok($e, $class, $prefix); + is("$e", "$class: message\n", "$prefix: as_string()"); + is($e->get_message(), 'message', "$prefix: get_message()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker.t new file mode 100755 index 0000000..ea7aba4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = "normal"; + my %OPTIONS = (option1 => 1, option2 => 2, option3 => 3); + my @ARGUMENTS = ('argument 1', 'argument 2'); + my $invoker = $class->new({ + command => 'command', + options => \%OPTIONS, + arguments => \@ARGUMENTS, + }); + isa_ok($invoker, $class, $prefix); + is($invoker->get_command(), 'command', "$prefix: command"); + is_deeply({$invoker->get_options()}, \%OPTIONS, "$prefix: options"); + is_deeply([$invoker->get_arguments()], \@ARGUMENTS, "$prefix: arguments"); + eval { + $invoker->invoke(); + }; + isa_ok($@, 'Fcm::CLI::Exception', "$prefix: invoke"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/Browser.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/Browser.t new file mode 100755 index 0000000..7fa712a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/Browser.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::Browser'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/CM.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/CM.t new file mode 100755 index 0000000..a514e55 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/CM.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::CM'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/CfgPrinter.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/CfgPrinter.t new file mode 100755 index 0000000..0648137 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/CfgPrinter.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::CfgPrinter'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/ConfigSystem.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/ConfigSystem.t new file mode 100755 index 0000000..cd2745a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/ConfigSystem.t @@ -0,0 +1,94 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A mock Fcm::ConfigSystem object +{ + package MockConfigSystem; + use base qw{Fcm::ConfigSystem}; + + our $LATEST_INVOKED_INSTANCE; + + ############################################################################ + # Returns the arguments to the last invoke() call + sub get_invoke_args { + my ($self) = @_; + return $self->{invoke_args}; + } + + ############################################################################ + # Does nothing but captures the arguments + sub invoke { + my ($self, %args) = @_; + $LATEST_INVOKED_INSTANCE = $self; + $self->{invoke_args} = \%args; + return 1; + } +} + +use Cwd; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::ConfigSystem'; + use_ok($class); + test_invoke($class); +} + +################################################################################ +# Tests normal usage of invoke() +sub test_invoke { + my ($class) = @_; + my $prefix = "invoke"; + my %TEST = ( + test1 => { + command => 'pig', + options => {'egg' => 1}, + arguments => ['bacon'], + expected_options => {FOO => undef, BAR_BAZ => undef, EGGS => 1}, + expected_arguments => 'bacon', + }, + test2 => { + command => 'pig', + options => {'foo' => 1, 'bar-baz' => 1}, + arguments => [], + expected_options => {FOO => 1, BAR_BAZ => 1, EGGS => undef}, + expected_arguments => cwd(), + } + ); + for my $key (keys(%TEST)) { + my $invoker = $class->new({ + command => $TEST{$key}{command}, + options => $TEST{$key}{options}, + arguments => $TEST{$key}{arguments}, + impl_class => 'MockConfigSystem', + cli2invoke_key_map => { + 'foo' => 'FOO', 'bar-baz' => 'BAR_BAZ', 'egg' => 'EGGS', + }, + }); + isa_ok($invoker, 'Fcm::CLI::Invoker::ConfigSystem', "$prefix: $key"); + $invoker->invoke(); + my $config_system_instance = $MockConfigSystem::LATEST_INVOKED_INSTANCE; + isa_ok( + $config_system_instance, + 'Fcm::ConfigSystem', + "$prefix: $key: Fcm::ConfigSystem", + ); + is( + $config_system_instance->cfg()->src(), + $TEST{$key}{expected_arguments}, + "$prefix: $key: cfg()->src()", + ); + is_deeply( + $config_system_instance->get_invoke_args(), + $TEST{$key}{expected_options}, + "$prefix: $key: invoke args", + ); + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/ExtractConfigComparator.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/ExtractConfigComparator.t new file mode 100755 index 0000000..1eb40da --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/ExtractConfigComparator.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::ExtractConfigComparator'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/GUI.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/GUI.t new file mode 100755 index 0000000..fd51538 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/GUI.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::GUI'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/Help.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/Help.t new file mode 100755 index 0000000..fdf22bc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/Help.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::Help'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/KeywordPrinter.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/KeywordPrinter.t new file mode 100755 index 0000000..c65afd2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Invoker/KeywordPrinter.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Invoker::KeywordPrinter'; + use_ok($class); +} + +# TODO: actual unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Option.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Option.t new file mode 100755 index 0000000..847263f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Option.t @@ -0,0 +1,168 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Option'; + use_ok($class); + test_simplest($class); + test_simplest_scalar_arg($class); + test_simplest_array_arg($class); + test_simplest_hash_arg($class); + test_simple($class); + test_simple_scalar_arg($class); + test_simple_array_arg($class); + test_simple_hash_arg($class); + test_long_letter($class); +} + +################################################################################ +# Tests simplest usage +sub test_simplest { + my ($class) = @_; + my $prefix = 'simplest'; + my $option = $class->new({ + delimiter => 'delimiter-value', + description => 'description value', + name => 'name-value', + }); + isa_ok($option, $class); + is($option->get_delimiter(), 'delimiter-value', "$prefix: delimiter"); + is($option->get_description(), 'description value', "$prefix: description"); + is($option->get_name(), 'name-value', "$prefix: name"); + is($option->get_letter(), undef, "$prefix: letter"); + ok(!$option->has_arg(), "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with a scalar argument +sub test_simplest_scalar_arg { + my ($class) = @_; + my $prefix = 'simplest scalar arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + has_arg => $class->SCALAR_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->SCALAR_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value=s', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with array argument +sub test_simplest_array_arg { + my ($class) = @_; + my $prefix = 'simplest array arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + has_arg => $class->ARRAY_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->ARRAY_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value=s@', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with hash argument +sub test_simplest_hash_arg { + my ($class) = @_; + my $prefix = 'simplest hash arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + has_arg => $class->HASH_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->HASH_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value=s%', "$prefix: has arg"); +} + +################################################################################ +# Tests simple usage +sub test_simple { + my ($class) = @_; + my $prefix = 'simple'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + }); + isa_ok($option, $class); + is($option->get_description(), 'description value', "$prefix: description"); + is($option->get_name(), 'name-value', "$prefix: name"); + is($option->get_letter(), 'n', "$prefix: letter"); + is($option->has_arg(), $class->NO_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n', "$prefix: has arg"); +} + +################################################################################ +# Tests simple usage with a scalar argument +sub test_simple_scalar_arg { + my ($class) = @_; + my $prefix = 'simple scalar arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + has_arg => $class->SCALAR_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->SCALAR_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n=s', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with array argument +sub test_simple_array_arg { + my ($class) = @_; + my $prefix = 'simple array arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + has_arg => $class->ARRAY_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->ARRAY_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n=s@', "$prefix: has arg"); +} + +################################################################################ +# Tests simplest usage with hash argument +sub test_simple_hash_arg { + my ($class) = @_; + my $prefix = 'simple hash arg'; + my $option = $class->new({ + description => 'description value', + name => 'name-value', + letter => 'n', + has_arg => $class->HASH_ARG, + }); + isa_ok($option, $class); + is($option->has_arg(), $class->HASH_ARG, "$prefix: has arg"); + is($option->get_arg_for_getopt_long(), 'name-value|n=s%', "$prefix: has arg"); +} + +################################################################################ +# Tests longer than 1 letter +sub test_long_letter { + my ($class) = @_; + my $prefix = 'long letter'; + my $option = $class->new({ + name => 'name-value', + letter => 'name', + }); + isa_ok($option, $class); + is($option->get_letter(), 'n', "$prefix: letter"); + is($option->get_arg_for_getopt_long(), 'name-value|n', "$prefix: has arg"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Subcommand.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Subcommand.t new file mode 100755 index 0000000..22c6c88 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/CLI/Subcommand.t @@ -0,0 +1,74 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::CLI::Option; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::CLI::Subcommand'; + use_ok($class); + test_constructor($class); + test_has_a_name($class); + test_as_string($class); +} + +################################################################################ +# Tests the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my %OPTION_OF = ( + description => 'description value', + invoker_class => 'invoker_class value', + invoker_config => 'invoker_config value', + is_vc => 'is_vc value', + names => 'names value', + options => 'options value', + synopsis => 'synopsis value', + usage => 'usage value', + ); + my $subcommand = Fcm::CLI::Subcommand->new(\%OPTION_OF); + isa_ok($subcommand, $class, $prefix); + for my $key (keys(%OPTION_OF)) { + my $getter = index($key, 'is') == 0 ? $key : "get_$key"; + is($subcommand->$getter(), $OPTION_OF{$key}, "$prefix: $getter"); + } +} + +################################################################################ +# Tests match a string name to a subcommand +sub test_has_a_name { + my ($class) = @_; + my $prefix = 'has a name'; + my @NAMES = ('foo', 'bar', 'baz'); + my $subcommand = $class->new({names => \@NAMES}); + for my $name (@NAMES) { + ok($subcommand->has_a_name($name), "$prefix: $name"); + } + for my $name (qw{egg ham mayo}) { + ok(!$subcommand->has_a_name($name), "$prefix: $name"); + } +} + +################################################################################ +# Tests string representation of a subcommand +sub test_as_string { + my ($class) = @_; + my $prefix = 'as string'; + my %OPTION_OF = ( + 'foo (bar, baz)' => ['foo', 'bar', 'baz'], + 'foo (bar)' => ['foo', 'bar'], + 'foo' => ['foo'], + q{} => [], + ); + for my $key (keys(%OPTION_OF)) { + my $subcommand = $class->new({names => $OPTION_OF{$key}}); + is($subcommand->as_string(), $key, "$prefix: $key"); + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/ConfigSystem.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/ConfigSystem.t new file mode 100644 index 0000000..f02cf01 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/ConfigSystem.t @@ -0,0 +1,170 @@ +#!/usr/bin/perl +# ------------------------------------------------------------------------------ +# (C) Crown copyright Met Office. All rights reserved. +# For further details please refer to the file COPYRIGHT.txt +# which you should have received as part of this distribution. +# ------------------------------------------------------------------------------ + +use strict; +use warnings; + +use Fcm::CfgLine; +use Fcm::Config; +use Scalar::Util qw{reftype}; +use Test::More (tests => 90); + +BEGIN: { + use_ok('Fcm::ConfigSystem'); +} + +my $CONFIG = undef; + +# ------------------------------------------------------------------------------ +if (!caller()) { + main(@ARGV); +} + +# ------------------------------------------------------------------------------ +sub main { + local @ARGV = @_; + test_compare_setting_in_config(); +} + +# ------------------------------------------------------------------------------ +# Tests "compare_setting_in_config". +sub test_compare_setting_in_config { + my $PREFIX = 'TEST'; + my %S = (egg => [qw{boiled poached}], ham => 'roasted', bacon => 'fried'); + my %S_MOD = (ham => 'boiled'); + my %S_MOD_ARRAY = (egg => [qw{scrambled omelette}]); + my %S_ADD = (mushroom => 'sauteed'); + my %S_DEL = (bacon => undef); + + my @ITEMS = ( + { + name => 'empty', + original => {}, + added => {}, + removed => {}, + modified => {}, + }, + { + name => 'add keys to empty', + original => {}, + added => {%S}, + removed => {}, + modified => {%S}, + }, + { + name => 'remove all', + original => {%S}, + added => {}, + removed => {}, + modified => {map {($_, undef)} keys(%S)}, + }, + { + name => 'no change', + original => {%S}, + added => {%S}, + removed => {}, + modified => {}, + }, + { + name => 'modify key', + original => {%S}, + added => {%S, %S_MOD}, + removed => {}, + modified => {%S_MOD}, + }, + { + name => 'modify an array key', + original => {%S}, + added => {%S, %S_MOD_ARRAY}, + removed => {}, + modified => {%S_MOD_ARRAY}, + }, + { + name => 'add a key', + original => {%S}, + added => {%S, %S_ADD}, + removed => {}, + modified => {%S_ADD}, + }, + { + name => 'delete a key', + original => {%S}, + added => {%S}, + removed => {%S_DEL}, + modified => {%S_DEL}, + }, + { + name => 'modify a key and delete a key', + original => {%S}, + added => {%S, %S_MOD}, + removed => {%S_DEL}, + modified => {%S_MOD, %S_DEL}, + }, + { + name => 'add a key and delete a key', + original => {%S}, + added => {%S, %S_ADD}, + removed => {%S_DEL}, + modified => {%S_ADD, %S_DEL}, + }, + ); + + # A naive function to serialise an array reference + my $flatten = sub { + if (ref($_[0]) && reftype($_[0]) eq 'ARRAY') { + join(q{ }, sort(@{$_[0]})) + } + else { + $_[0]; + } + }; + + my $CONFIG = Fcm::Config->instance(); + for my $item (@ITEMS) { + # New settings + $CONFIG->{setting}{$PREFIX} = {%{$item->{added}}}; + for my $key (keys(%{$item->{removed}})) { + delete($CONFIG->{setting}{$PREFIX}{$key}); + } + + # Old lines + my @old_lines = map { + Fcm::CfgLine->new( + LABEL => $PREFIX . $Fcm::Config::DELIMITER . $_, + VALUE => $flatten->($item->{original}{$_}), + ) + } keys(%{$item->{original}}); + + # Invokes the method + my $system = Fcm::ConfigSystem->new(); + my ($changed_hash_ref, $new_cfg_lines_ref) + = $system->compare_setting_in_config($PREFIX, \@old_lines); + + # Tests the return values + my $T = $item->{name}; + is_deeply( + $changed_hash_ref, $item->{modified}, + "$T: \$changed_hash_ref content", + ); + is( + scalar(@{$new_cfg_lines_ref}), + scalar(keys(%{$item->{added}})) - scalar(keys(%{$item->{removed}})), + "$T: \$new_cfg_lines_ref length", + ); + for my $line (@{$new_cfg_lines_ref}) { + my $key = $line->label_from_field(1); + ok(exists($item->{added}{$key}), "$T: expected label $key"); + ok(!exists($item->{removed}{$key}), "$T: unexpected label $key"); + is( + $line->value(), $flatten->($item->{added}{$key}), + "$T: line content $key", + ); + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Exception.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Exception.t new file mode 100755 index 0000000..5f3d7ff --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Exception.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Exception'; + use_ok($class); + test_constructor_empty($class); + test_normal($class); +} + +################################################################################ +# Tests empty constructor +sub test_constructor_empty { + my ($class) = @_; + my $prefix = 'empty constructor'; + my $e = $class->new(); + isa_ok($e, $class, $prefix); + isnt("$e", undef, "$prefix: as_string() not undef"); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $e = $class->new({message => 'message'}); + isa_ok($e, $class, $prefix); + is("$e", "$class: message\n", "$prefix: as_string()"); + is($e->get_message(), 'message', "$prefix: get_message()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/ExtractConfigComparator.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/ExtractConfigComparator.t new file mode 100755 index 0000000..ee3c0ba --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/ExtractConfigComparator.t @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::ExtractConfigComparator'; + use_ok($class); +} + +# TODO: more real tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive.t new file mode 100755 index 0000000..c845bb2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive.t @@ -0,0 +1,94 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A sub-class of Fcm::Interactive::InputGetter for testing +{ + package TestInputGetter; + use base qw{Fcm::Interactive::InputGetter}; + + ############################################################################ + # A callback for testing + sub get_callback { + my ($self) = @_; + return $self->{callback}; + } + + ############################################################################ + # Returns some pre-defined strings + sub invoke { + my ($self) = @_; + $self->get_callback()->( + $self->get_title(), + $self->get_message(), + $self->get_type(), + $self->get_default(), + ); + return 'answer'; + } +} + +use Test::More qw{no_plan}; + +main(); + +sub main { + use_ok('Fcm::Interactive'); + test_default_impl(); + test_set_impl(); + test_get_input(); +} + +################################################################################ +# Tests default setting of input getter implementation +sub test_default_impl { + my $prefix = 'default impl'; + my ($class_name, $class_options_ref) = Fcm::Interactive::get_default_impl(); + is($class_name, 'Fcm::Interactive::InputGetter::CLI', "$prefix: class name"); + is_deeply($class_options_ref, {}, "$prefix: class options"); +} + +################################################################################ +# Tests setting the input getter implementation +sub test_set_impl { + my $prefix = 'set impl'; + my %options = (extra => 'extra-value'); + my $name = 'TestInputGetter'; + Fcm::Interactive::set_impl($name, \%options); + my ($class_name, $class_options_ref) = Fcm::Interactive::get_impl(); + is($class_name, $name, "$prefix: class name"); + is_deeply($class_options_ref, \%options, "$prefix: class options"); +} + +################################################################################ +# Tests getting input with test input getter +sub test_get_input { + my $prefix = 'get input'; + my %EXPECTED = ( + TITLE => 'title-value', + MESSAGE => 'message-value', + TYPE => 'type-value', + DEFAULT => 'default-value', + ANSWER => 'answer', + ); + Fcm::Interactive::set_impl('TestInputGetter', { + callback => sub { + my ($title, $message, $type, $default) = @_; + is($title, $EXPECTED{TITLE}, "$prefix: title"); + is($message, $EXPECTED{MESSAGE}, "$prefix: message"); + is($type, $EXPECTED{TYPE}, "$prefix: type"); + is($default, $EXPECTED{DEFAULT}, "$prefix: default"); + }, + }); + my $ans = Fcm::Interactive::get_input( + title => $EXPECTED{TITLE}, + message => $EXPECTED{MESSAGE}, + type => $EXPECTED{TYPE}, + default => $EXPECTED{DEFAULT}, + ); + is($ans, $EXPECTED{ANSWER}, "$prefix: answer"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter.t new file mode 100755 index 0000000..9dc3daf --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Interactive::InputGetter'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests usage of constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my $input_getter = $class->new({ + title => 'title-value', + message => 'message-value', + type => 'type-value', + default => 'default-value', + }); + isa_ok($input_getter, $class); + is($input_getter->get_title(), 'title-value', "$prefix: get title"); + is($input_getter->get_message(), 'message-value', "$prefix: get message"); + is($input_getter->get_type(), 'type-value', "$prefix: get type"); + is($input_getter->get_default(), 'default-value', "$prefix: get default"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter/CLI.pm b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter/CLI.pm new file mode 100755 index 0000000..069396a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter/CLI.pm @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Interactive::InputGetter::CLI'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests usage of constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my $input_getter = $class->new({}); + isa_ok($input_getter, $class); +} + +# TODO: tests the invoke method + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter/GUI.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter/GUI.t new file mode 100755 index 0000000..1c8aae4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Interactive/InputGetter/GUI.t @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Interactive::InputGetter::GUI'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests usage of constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my $input_getter = $class->new({ + title => 'title-value', + message => 'message-value', + type => 'type-value', + default => 'default-value', + geometry => 'geometry-value', + }); + isa_ok($input_getter, $class); + is($input_getter->get_geometry(), 'geometry-value', "$prefix: geometry"); +} + +# TODO: tests the invoke method + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword.t new file mode 100755 index 0000000..cb069dd --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword.t @@ -0,0 +1,323 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Carp qw{croak}; +use Fcm::Keyword::Config; +use Test::More (tests => 227); + +BEGIN: { + use_ok('Fcm::Keyword'); +} + +if (!caller()) { + main(@ARGV); +} + +sub main { + local @ARGV = @_; + local %Fcm::Keyword::Config::CONFIG_OF = ( + LOCATION_ENTRIES => {entry_class => 'Fcm::Keyword::Entry::Location'}, + REVISION_ENTRIES => {entry_class => 'Fcm::Keyword::Entry'}, + ); + test_get_prefix_of_location_keyword(); + test_get_entries(); + test_expand(); + test_unexpand(); + test_get_browser_url(); +} + +################################################################################ +# Tests get_prefix_of_location_keyword(). +sub test_get_prefix_of_location_keyword { + is(Fcm::Keyword::get_prefix_of_location_keyword(), 'fcm'); + is(Fcm::Keyword::get_prefix_of_location_keyword(1), 'fcm:'); +} + +################################################################################ +# Tests get_entries(). +sub test_get_entries { + my $entries = Fcm::Keyword::get_entries(); + isa_ok($entries, 'Fcm::Keyword::Entries'); + for (1 .. 10) { + is(Fcm::Keyword::get_entries(), $entries, "get_entries: is singleton"); + } + isnt(Fcm::Keyword::get_entries(1), $entries, "get_entries: can reset"); +} + +################################################################################ +# Tests expand(). +sub test_expand { + my $T = 'expand'; + + # Add some keywords for testing + _add_keyword_entries([ + # ['name' , 'value' , {'rev1' => rev, ...}], + ['FOO' , 'test://foo/foo' , {'V1.0' => 256, 'V1-1' => 4790}], + ['FOO-TR', 'test://foo/foo/trunk', {}], + ]); + + _do_keyword_tests($T, \&Fcm::Keyword::expand, [ + # Tests to ensure that valid targets are expanded + # [['input' ], ['expected' ]], + [['fcm:FOO' ], ['test://foo/foo' ]], + [['fcm:FOO' , 'V1.0'], ['test://foo/foo' , '256' ]], + [['fcm:Foo' ], ['test://foo/foo' ]], + [['fcm:foo' ], ['test://foo/foo' ]], + [['fcm:foo' , 'v1.0'], ['test://foo/foo' , '256' ]], + [['fcm:foo' , 'head'], ['test://foo/foo' , 'head']], + [['fcm:foo/' ], ['test://foo/foo/' ]], + [['fcm:foo/' , '1234'], ['test://foo/foo/' , '1234']], + [['fcm:foo/' , 'v1.0'], ['test://foo/foo/' , '256' ]], + [['fcm:foo/' , 'v1-1'], ['test://foo/foo/' , '4790']], + [['fcm:foo/bar' ], ['test://foo/foo/bar' ]], + [['fcm:foo/bar' , 'PREV'], ['test://foo/foo/bar' , 'PREV']], + [['fcm:foo/bar' , 'base'], ['test://foo/foo/bar' , 'base']], + [['fcm:foo/bar' , 'v1-1'], ['test://foo/foo/bar' , '4790']], + [['fcm:foo/bar/', '7777'], ['test://foo/foo/bar/' , '7777']], + [['fcm:foo/bar/', '{11}'], ['test://foo/foo/bar/' , '{11}']], + [['fcm:foo/bar/', 'v1.0'], ['test://foo/foo/bar/' , '256' ]], + [['fcm:foo-tr' ], ['test://foo/foo/trunk' ]], + [['fcm:foo-tr' , 'head'], ['test://foo/foo/trunk' , 'head']], + [['fcm:foo-tr' , 'v1.0'], ['test://foo/foo/trunk' , '256' ]], + [['fcm:foo-tr/' ], ['test://foo/foo/trunk/' ]], + [['fcm:foo-tr/' , '1234'], ['test://foo/foo/trunk/', '1234']], + [['fcm:foo-tr/' , 'v1-1'], ['test://foo/foo/trunk/', '4790']], + # Tests to ensure that non-keyword targets are not expanded + # [['input' ]], # 'expected' same as 'input' + [['no-change' ]], + [['foo/bar' ]], + [['/foo/bar' ]], + [['/foo/bar' , 'head' ]], + [['/foo/bar/' ]], + [['/foo/bar/' , 'not-a-key']], + [['svn://foo/bar' ]], + [['svn://foo/bar', '1234' ]], + [['file://foo/bar' ]], + [['http://foo/bar' ]], + ]); + + # Tests for unexpected keywords + for my $key (qw{foo bar baz}) { + eval { + Fcm::Keyword::expand("fcm:foo\@$key"); + }; + isa_ok($@, 'Fcm::Keyword::Exception', "$T: $key: invalid revision"); + } + + # Tests for "undef", all expecting exceptions + for my $target_ref ([undef], [undef, undef], [undef, 'foo']) { + eval { + Fcm::Keyword::expand(@{$target_ref}); + }; + isa_ok($@, 'Fcm::Exception', "$T: undef"); + } +} + +################################################################################ +# Tests unexpand(). +sub test_unexpand { + my $T = 'unexpand'; + + # Add some keywords for testing + _add_keyword_entries([ + # ['name' , 'value' , {'rev1' => rev, ...}], + ['FOO' , 'test://foo/foo' , {'V1.0' => 256, 'V1-1' => 4790}], + ['FOO_TR', 'test://foo/foo/trunk', {}], + ['FOO-TR', 'test://foo/foo/trunk', {}], + ]); + + _do_keyword_tests($T, \&Fcm::Keyword::unexpand, [ + # Tests to ensure that valid targets are expanded + # [['input' ], ['expected' ]], + [['test://foo/foo' ], ['fcm:FOO' ]], + [['test://foo/foo' , '256' ], ['fcm:FOO' , 'V1.0']], + [['test://foo/foo' , 'head'], ['fcm:FOO' , 'head']], + [['test://foo/foo/' ], ['fcm:FOO/' ]], + [['test://foo/foo/' , '1234'], ['fcm:FOO/' , '1234']], + [['test://foo/foo/' , '256' ], ['fcm:FOO/' , 'V1.0']], + [['test://foo/foo/' , '4790'], ['fcm:FOO/' , 'V1-1']], + [['test://foo/foo/bar' ], ['fcm:FOO/bar' ]], + [['test://foo/foo/bar' , 'PREV'], ['fcm:FOO/bar' , 'PREV']], + [['test://foo/foo/bar' , 'base'], ['fcm:FOO/bar' , 'base']], + [['test://foo/foo/bar' , '4790'], ['fcm:FOO/bar' , 'V1-1']], + [['test://foo/foo/bar/' , '7777'], ['fcm:FOO/bar/', '7777']], + [['test://foo/foo/bar/' , '{11}'], ['fcm:FOO/bar/', '{11}']], + [['test://foo/foo/bar/' , '256' ], ['fcm:FOO/bar/', 'V1.0']], + [['test://foo/foo/trunk' ], ['fcm:FOO-TR' ]], + [['test://foo/foo/trunk' , 'head'], ['fcm:FOO-TR' , 'head']], + [['test://foo/foo/trunk' , '256' ], ['fcm:FOO-TR' , 'V1.0']], + [['test://foo/foo/trunk/' ], ['fcm:FOO-TR/' ]], + [['test://foo/foo/trunk/', '1234'], ['fcm:FOO-TR/' , '1234']], + [['test://foo/foo/trunk/', '4790'], ['fcm:FOO-TR/' , 'V1-1']], + # Tests to ensure that non-keyword targets are not expanded + # [['input' ]], # 'expected' same as 'input' + [['no-change' ]], + [['foo/bar' ]], + [['/foo/bar' ]], + [['/foo/bar' , 'head' ]], + [['/foo/bar/' ]], + [['/foo/bar/' , 'not-a-key']], + [['svn://foo/bar' ]], + [['svn://foo/bar', '1234' ]], + [['file://foo/bar' ]], + [['http://foo/bar' ]], + ]); + + # Tests for "undef", all expecting exceptions + for my $target_ref ([undef], [undef, undef], [undef, 'foo']) { + eval { + Fcm::Keyword::unexpand(@{$target_ref}); + }; + isa_ok($@, 'Fcm::Exception', "$T: undef"); + } +} + +################################################################################ +# Tests get_browser_url(). +sub test_get_browser_url { + my $T = 'get_browser_url'; + + # Add some keywords for testing + _add_keyword_entries([ + # ['name' , 'value' , {'rev1' => rev, ...}], + ['FOO' , 'test://foo/foo_svn/foo' , {'V1' => 256, 'W2' => 479}], + ['FOO-TR', 'test://foo/foo_svn/foo/trunk'], + ['FOO_TR', 'test://foo/foo_svn/foo/trunk'], + ]); + + my ($INPUT, $EXPECTED) = (0, 1); + my ($LOC, $REV) = (0, 1); + for my $test_ref ( + # Tests to ensure that valid targets are expanded + # [['input' ], 'expected' ], + [['test://foo/foo_svn/foo' ], 'http://foo/projects/foo/intertrac/source:foo' ], + [['test://foo/foo_svn/foo' , '256' ], 'http://foo/projects/foo/intertrac/source:foo@256' ], + [['test://foo/foo_svn/foo' , 'head'], 'http://foo/projects/foo/intertrac/source:foo@head' ], + [['test://foo/foo_svn/foo/' ], 'http://foo/projects/foo/intertrac/source:foo/' ], + [['test://foo/foo_svn/foo/' , '1234'], 'http://foo/projects/foo/intertrac/source:foo/@1234' ], + [['test://foo/foo_svn/foo/' , '256' ], 'http://foo/projects/foo/intertrac/source:foo/@256' ], + [['test://foo/foo_svn/foo/' , '479' ], 'http://foo/projects/foo/intertrac/source:foo/@479' ], + [['test://foo/foo_svn/foo/bar' ], 'http://foo/projects/foo/intertrac/source:foo/bar' ], + [['test://foo/foo_svn/foo/bar' , '479' ], 'http://foo/projects/foo/intertrac/source:foo/bar@479' ], + [['test://foo/foo_svn/foo/bar/' , '7777'], 'http://foo/projects/foo/intertrac/source:foo/bar/@7777' ], + [['test://foo/foo_svn/foo/bar/' , '{11}'], 'http://foo/projects/foo/intertrac/source:foo/bar/@{11}' ], + [['test://foo/foo_svn/foo/bar/' , '256' ], 'http://foo/projects/foo/intertrac/source:foo/bar/@256' ], + [['test://foo/foo_svn/foo/trunk' ], 'http://foo/projects/foo/intertrac/source:foo/trunk' ], + [['test://foo/foo_svn/foo/trunk' , 'head'], 'http://foo/projects/foo/intertrac/source:foo/trunk@head' ], + [['test://foo/foo_svn/foo/trunk' , '256' ], 'http://foo/projects/foo/intertrac/source:foo/trunk@256' ], + [['test://foo/foo_svn/foo/trunk/' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/' ], + [['test://foo/foo_svn/foo/trunk/', '1234'], 'http://foo/projects/foo/intertrac/source:foo/trunk/@1234'], + [['test://foo/foo_svn/foo/trunk/', '479' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/@479' ], + [['fcm:FOO' ], 'http://foo/projects/foo/intertrac/source:foo' ], + [['fcm:FOO' , 'V1' ], 'http://foo/projects/foo/intertrac/source:foo@256' ], + [['fcm:FOO' , 'head'], 'http://foo/projects/foo/intertrac/source:foo@head' ], + [['fcm:FOO/' ], 'http://foo/projects/foo/intertrac/source:foo/' ], + [['fcm:FOO/' , '1234'], 'http://foo/projects/foo/intertrac/source:foo/@1234' ], + [['fcm:FOO/' , 'V1' ], 'http://foo/projects/foo/intertrac/source:foo/@256' ], + [['fcm:FOO/' , 'W2' ], 'http://foo/projects/foo/intertrac/source:foo/@479' ], + [['fcm:FOO/bar' ], 'http://foo/projects/foo/intertrac/source:foo/bar' ], + [['fcm:FOO/bar' , 'W2' ], 'http://foo/projects/foo/intertrac/source:foo/bar@479' ], + [['fcm:FOO/bar/' , '7777'], 'http://foo/projects/foo/intertrac/source:foo/bar/@7777' ], + [['fcm:FOO/bar/' , '{11}'], 'http://foo/projects/foo/intertrac/source:foo/bar/@{11}' ], + [['fcm:FOO/bar/' , 'v1' ], 'http://foo/projects/foo/intertrac/source:foo/bar/@256' ], + [['fcm:FOO-TR' ], 'http://foo/projects/foo/intertrac/source:foo/trunk' ], + [['fcm:FOO-TR' , 'head'], 'http://foo/projects/foo/intertrac/source:foo/trunk@head' ], + [['fcm:FOO-TR' , 'V1' ], 'http://foo/projects/foo/intertrac/source:foo/trunk@256' ], + [['fcm:FOO-TR/' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/' ], + [['fcm:FOO-TR/' , '1234'], 'http://foo/projects/foo/intertrac/source:foo/trunk/@1234'], + [['fcm:FOO-TR/' , 'w2' ], 'http://foo/projects/foo/intertrac/source:foo/trunk/@479' ], + ) { + my $input = $test_ref->[$INPUT][$LOC]; + if (exists($test_ref->[$INPUT][$REV])) { + $input .= '@' . $test_ref->[$INPUT][$REV]; + } + for ( + {name => "$T: scalar input: $input", input => [$input]}, + {name => "$T: list input: $input" , input => $test_ref->[$INPUT]}, + ) { + my $output; + eval { + $output = Fcm::Keyword::get_browser_url(@{$_->{input}}); + is($output, $test_ref->[$EXPECTED], $_->{name}); + }; + if ($@) { + fail("$_->{name}: $@"); + } + } + } + + # Tests correct behaviour for "undef" + for my $bad_url (undef, '') { + eval { + Fcm::Keyword::get_browser_url($bad_url); + }; + isa_ok($@, 'Fcm::Exception', sprintf( + "$T: %s", (defined($bad_url) ? $bad_url : 'undef'), + )); + } + + # Tests correct behaviour for invalid inputs + for my $bad_url ('foo', 'svn://no/such/url', 'fcm:no_such_project/trunk') { + eval { + Fcm::Keyword::get_browser_url($bad_url); + }; + isa_ok($@, 'Fcm::Keyword::Exception', "$T: $bad_url: invalid keyword"); + } +} + +################################################################################ +# Adds keyword entries. +sub _add_keyword_entries { + my ($items_ref) = @_; + my ($NAME, $LOC, $REV) = (0 .. 2); + my $entries = Fcm::Keyword::get_entries(1); # reset + for my $item_ref (@{$items_ref}) { + my $entry = $entries->add_entry($item_ref->[$NAME], $item_ref->[$LOC]); + while (my ($key, $value) = each(%{$item_ref->[$REV]})) { + $entry->get_revision_entries()->add_entry($key, $value); + } + } +} + +################################################################################ +# Performs keyword testings. +sub _do_keyword_tests { + my ($T, $action_ref, $tests_ref) = @_; + my ($INPUT, $EXPECTED) = (0, 1); + my ($LOC, $REV) = (0, 1); + for my $test_ref (@{$tests_ref}) { + if (!defined($test_ref->[$EXPECTED])) { + $test_ref->[$EXPECTED] = $test_ref->[$INPUT]; + } + my %value_of; + for my $i (0 .. $#{$test_ref}) { + $value_of{$i} = $test_ref->[$i][$LOC]; + if (exists($test_ref->[$i][$REV])) { + $value_of{$i} .= '@' . $test_ref->[$i][$REV]; + } + } + eval { + is( + $action_ref->($value_of{$INPUT}), $value_of{$EXPECTED}, + "$T: scalar context: $value_of{$INPUT}", + ); + }; + if ($@) { + fail("$T: scalar context: $value_of{$INPUT}: $@"); + } + eval { + is_deeply( + [$action_ref->(@{$test_ref->[$INPUT]})], + $test_ref->[$EXPECTED], + "$T: list context: $value_of{$INPUT}", + ); + }; + if ($@) { + fail("$T: list context: $value_of{$INPUT}: $@"); + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Config.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Config.t new file mode 100755 index 0000000..da3e1e0 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Config.t @@ -0,0 +1,15 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $module = 'Fcm::Keyword::Config'; + use_ok($module); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entries.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entries.t new file mode 100755 index 0000000..d1c919f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entries.t @@ -0,0 +1,228 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A Fcm::Keyword::Entry sub-class for testing +{ + package TestEntry; + use base qw{Fcm::Keyword::Entry}; +} + +################################################################################ +# A mock loader implementing the Fcm::Keyword::Loader interface +{ + package MockLoader0; + use Scalar::Util qw{blessed}; + + ############################################################################ + # Constructor + sub new { + my ($class) = @_; + return bless({number_of_calls_to_load_to => 0}, $class); + } + + ############################################################################ + ##Returns the package name + sub get_source { + my ($self) = @_; + return blessed($self); + } + + ############################################################################ + # Returns number of times $self->load_to() has been called + sub get_number_of_calls_to_load_to { + my ($self) = @_; + return $self->{number_of_calls_to_load_to}; + } + + ############################################################################ + # Loads data into $entries, and returns number of entries loaded + sub load_to { + my ($self, $entries) = @_; + $self->{number_of_calls_to_load_to}++; + return $self->load_to_impl($entries); + } + + ############################################################################ + # Returns 0 + sub load_to_impl { + my ($self, $entries) = @_; + return 0; + } +} + +################################################################################ +# A mock loader implementing the Fcm::Keyword::Loader interface +{ + package MockLoader1; + our @ISA = qw{MockLoader0}; + + my %VALUE_OF = (foo => 'foo1', bar => 'bar2', baz => 'baz3'); + + ############################################################################ + # Returns a reference to the mock data + sub get_data { + my ($class) = @_; + return \%VALUE_OF; + } + + ############################################################################ + ##Writes mock data to the $entries object + sub load_to_impl { + my ($self, $entries) = @_; + my $counter = 0; + for my $key (keys(%{$self->get_data()})) { + $entries->add_entry($key, $self->get_data()->{$key}); + $counter++; + } + return $counter; + } +} + +################################################################################ +# A mock loader implementing the Fcm::Keyword::Loader interface +{ + package MockLoader2; + our @ISA = qw{MockLoader1}; + + my %VALUE_OF = (sausages => 'pig', eggs => 'hen', chips => 'potato'); + + ############################################################################ + # Returns a reference to the mock data + sub get_data { + my ($class) = @_; + return \%VALUE_OF; + } +} + +package main; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Entries'; + use_ok($class); + test_empty_constructor($class); + test_constructor($class); + test_add_entry($class); + test_loaders($class); +} + +################################################################################ +# Tests empty constructor +sub test_empty_constructor { + my ($class) = @_; + my $prefix = 'empty constructor'; + my $entries = $class->new(); + isa_ok($entries, $class); + is($entries->get_entry_class(), 'Fcm::Keyword::Entry', + "$prefix: default entry class"); + is_deeply([$entries->get_loaders()], [], "$prefix: empty list of loaders"); + is_deeply([$entries->get_all_entries()], [], + "$prefix: empty list of entries"); + for my $arg ('foo', undef) { + is($entries->get_entry_by_key($arg), undef, + "$prefix: entry by key: undef"); + is($entries->get_entry_by_value($arg), undef, + "$prefix: entry by value: undef"); + } +} + +################################################################################ +# Tests other constructor usages +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + my @loaders = (MockLoader1->new(), MockLoader2->new()); + my $entries = $class->new({ + entry_class => 'not-a-class', + loaders => \@loaders, + }); + isa_ok($entries, $class); + is($entries->get_entry_class(), 'not-a-class', "$prefix: entry class"); + is_deeply([$entries->get_loaders()], \@loaders, "$prefix: list of loaders"); + eval { + $entries->add_entry('key', 'value'); + }; + isnt($@, undef, "$prefix: invalid entry class"); +} + +################################################################################ +# Tests adding entries +sub test_add_entry { + my ($class) = @_; + my $prefix = 'add entry'; + my %VALUE_OF = (key1 => 'value1', egg => 'white and yolk', 'xyz.abc' => ''); + for my $entry_class ('Fcm::Keyword::Entry', 'TestEntry') { + my $entries = $class->new({entry_class => $entry_class}); + my $number_of_entries = 0; + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->add_entry($key, $VALUE_OF{$key}); + isa_ok($entry, $entry_class); + is(scalar(@{$entries->get_all_entries()}), ++$number_of_entries, + "$prefix: number of entries: $number_of_entries"); + } + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->get_entry_by_key($key); + isa_ok($entry, $entry_class); + is($entry->get_key(), uc($key), "$prefix: get by key: $key"); + is($entry->get_value(), $VALUE_OF{$key}, + "$prefix: get by key: $key: value"); + } + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->get_entry_by_value($VALUE_OF{$key}); + isa_ok($entry, $entry_class); + is($entry->get_key(), uc($key), "$prefix: get by value: $key"); + is($entry->get_value(), $VALUE_OF{$key}, + "$prefix: get by value: $key: value"); + } + is($entries->get_entry_by_key('no-such-key'), undef, + "$prefix: get by key: no-such-key"); + is($entries->get_entry_by_value('no-such-value'), undef, + "$prefix: get by value: no-such-value"); + } +} + +################################################################################ +# Tests usage of loaders +sub test_loaders { + my ($class) = @_; + my $prefix = "loader"; + my @loaders = (MockLoader0->new(), MockLoader1->new(), MockLoader2->new()); + my $entries = $class->new({loaders => \@loaders}); + for my $loader (@loaders) { + is($loader->get_number_of_calls_to_load_to(), 0, "$prefix: not loaded"); + } + for my $key (keys(%{$loaders[1]->get_data()})) { + my $value = $loaders[1]->get_data()->{$key}; + my $entry = $entries->get_entry_by_key($key); + is($entry->get_key(), uc($key), "$prefix: by key: $key: key"); + is($entries->get_entry_by_value($value), $entry, + "$prefix: by value: $key: object"); + } + is($loaders[0]->get_number_of_calls_to_load_to(), 1, + "$prefix: loaded once: 0"); + is($loaders[1]->get_number_of_calls_to_load_to(), 1, + "$prefix: loaded once: 1"); + is($loaders[2]->get_number_of_calls_to_load_to(), 0, + "$prefix: not loaded: 2"); + for my $key (keys(%{$loaders[2]->get_data()})) { + my $value = $loaders[2]->get_data()->{$key}; + my $entry = $entries->get_entry_by_key($key); + is($entry->get_key(), uc($key), "$prefix: by key: $key: key"); + is($entries->get_entry_by_value($value), $entry, + "$prefix: by value: $key: object"); + } + is($loaders[0]->get_number_of_calls_to_load_to(), 2, + "$prefix: loaded once: 0"); + is($loaders[1]->get_number_of_calls_to_load_to(), 1, + "$prefix: loaded once: 1"); + is($loaders[2]->get_number_of_calls_to_load_to(), 1, + "$prefix: not loaded: 2"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entry.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entry.t new file mode 100644 index 0000000..bccc527 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entry.t @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Entry'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = 'Fcm::Keyword::Entry'; + my $entry = $class->new({key => 'key', value => 'value'}); + isa_ok($entry, $class); + is($entry->get_key(), 'key', "normal: get_key()"); + is($entry->get_value(), 'value', "normal: get_value()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entry/Location.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entry/Location.t new file mode 100755 index 0000000..36976a2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Entry/Location.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my ($class) = 'Fcm::Keyword::Entry::Location'; + use_ok($class); + test_constructor($class); +} + +################################################################################ +# Tests constructor +sub test_constructor { + my ($class) = @_; + my $prefix = 'constructor'; + isa_ok($class->new(), $class, "$prefix: empty"); + my $entry = $class->new({key => 'key', value => 'value'}); + isa_ok($entry, $class, "$prefix: normal"); + is($entry->get_key(), 'key', "$prefix: normal: get_key()"); + is($entry->get_value(), 'value', "$prefix: normal: get_value()"); + isa_ok($entry->get_revision_entries(), 'Fcm::Keyword::Entries'); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Exception.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Exception.t new file mode 100755 index 0000000..5a64cf6 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Exception.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Exception'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $e = $class->new({message => 'message'}); + isa_ok($e, $class, $prefix); + is("$e", "$class: message\n", "$prefix: as_string()"); + is($e->get_message(), 'message', "$prefix: get_message()"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entries.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entries.t new file mode 100755 index 0000000..27470e2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entries.t @@ -0,0 +1,31 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Keyword::Entries; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Formatter::Entries'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $formatter = $class->new(); + isa_ok($formatter, $class, $prefix); + my $entries = Fcm::Keyword::Entries->new(); + $entries->add_entry('foo', 'food'); + $entries->add_entry('bar', 'barley'); + is($formatter->format($entries), "BAR = barley\nFOO = food\n", + "$prefix: format"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entry.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entry.t new file mode 100755 index 0000000..58b7dd2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entry.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Keyword::Entry; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Formatter::Entry'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $formatter = $class->new(); + isa_ok($formatter, $class, $prefix); + my $entry = Fcm::Keyword::Entry->new({key => 'k', value => 'v'}); + is($formatter->format($entry), "k = v\n", "$prefix: format"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entry/Location.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entry/Location.t new file mode 100755 index 0000000..d263e3f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Formatter/Entry/Location.t @@ -0,0 +1,28 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Keyword::Entry::Location; +use Test::More qw{no_plan}; + +main(); + +sub main { + my $class = 'Fcm::Keyword::Formatter::Entry::Location'; + use_ok($class); + test_normal($class); +} + +################################################################################ +# Tests normal usage +sub test_normal { + my ($class) = @_; + my $prefix = 'normal'; + my $formatter = $class->new(); + isa_ok($formatter, $class, $prefix); + my $entry = Fcm::Keyword::Entry::Location->new({key => 'k', value => 'v'}); + like($formatter->format($entry), qr{k \s = \s v}xms, "$prefix: format"); +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/Config/Location.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/Config/Location.t new file mode 100755 index 0000000..23332e3 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/Config/Location.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Config; +use Fcm::Keyword::Entries; +use Test::More qw{no_plan}; + +my %VALUE_OF = ( + foo => 'fcm-test://foo/foo', + bar => 'fcm-test://bar/bar', + baz => 'fcm-test://baz/baz', +); + +main(); + +sub main { + my $class = 'Fcm::Keyword::Loader::Config::Location'; + use_ok($class); + test_constructor($class); + test_load_to($class); +} + +################################################################################ +# Tests simple usage of the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = "constructor"; + my $loader = $class->new(); + isa_ok($loader, $class); + is($loader->get_source(), 'Fcm::Config', "$prefix: get_source()"); +} + +################################################################################ +# Tests loading to an Fcm::Keyword::Entries object +sub test_load_to { + my ($class) = @_; + my $prefix = 'load to'; + my $config = Fcm::Config->instance(); + for my $key (keys(%VALUE_OF)) { + $config->setting(['URL', $key], $VALUE_OF{$key}); + } + my $loader = $class->new(); + my $entries = Fcm::Keyword::Entries->new({ + entry_class => 'Fcm::Keyword::Entry::Location', + }); + isnt($loader->load_to($entries), 0, "$prefix: number loaded"); + for my $key (keys(%VALUE_OF)) { + my $entry = $entries->get_entry_by_key($key); + if ($entry) { + is($entry->get_key(), uc($key), "$prefix: by key: $key"); + is($entry->get_value(), $VALUE_OF{$key}, "$prefix: by value: $key"); + is( + $entries->get_entry_by_value($VALUE_OF{$key}), + $entry, + "$prefix: by key: $key: object", + ); + } + else { + fail("$prefix: by key: $key"); + } + } +} + +# TODO: tests loading of browser mapping + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/Config/Revision.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/Config/Revision.t new file mode 100755 index 0000000..d70cb91 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/Config/Revision.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Fcm::Config; +use Fcm::Keyword::Entries; +use Test::More qw{no_plan}; + +my %VALUE_OF = ( + bar => { + 'bar3' => 3, + 'bar3.1' => 31, + 'bar3.14' => 314, + }, + baz => { + 'bear' => 4, + 'bee' => 6, + 'spider' => 8, + }, +); + +main(); + +sub main { + my $class = 'Fcm::Keyword::Loader::Config::Revision'; + use_ok($class); + test_constructor($class); + test_load_to($class); +} + +################################################################################ +# Tests simple usage of the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = "constructor"; + my $loader = $class->new({namespace => 'namespace'}); + isa_ok($loader, $class); + is($loader->get_namespace(), 'namespace', "$prefix: get_namespace()"); + is($loader->get_source(), 'Fcm::Config', "$prefix: get_source()"); +} + +################################################################################ +# Tests loading to an Fcm::Keyword::Entries object +sub test_load_to { + my ($class) = @_; + my $prefix = 'load to'; + my $config = Fcm::Config->instance(); + for my $key (keys(%VALUE_OF)) { + for my $rev_key (keys(%{$VALUE_OF{$key}})) { + my $value = $VALUE_OF{$key}{$rev_key}; + $config->setting(['URL_REVISION', uc($key), uc($rev_key)], $value); + } + my $entries = Fcm::Keyword::Entries->new(); + my $loader = $class->new({namespace => $key}); + isnt($loader->load_to($entries), 0, "$prefix: number loaded"); + for my $rev_key (keys(%{$VALUE_OF{$key}})) { + my $entry = $entries->get_entry_by_key($rev_key); + my $value = $VALUE_OF{$key}{$rev_key}; + if ($entry) { + is( + $entry->get_key(), + uc($rev_key), + "$prefix: by key: $rev_key", + ); + is($entry->get_value(), $value, "$prefix: by value: $rev_key"); + is( + $entries->get_entry_by_value($value), + $entry, + "$prefix: by key: $key: object", + ); + } + else { + fail("$prefix: by key: $rev_key"); + } + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.dump b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.dump new file mode 100644 index 0000000..5439074 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.dump @@ -0,0 +1,80 @@ +SVN-fs-dump-format-version: 2 + +UUID: 1a576f26-974a-0410-964b-c09797d35b3b + +Revision-number: 0 +Prop-content-length: 56 +Content-length: 56 + +K 8 +svn:date +V 27 +2008-04-11T11:22:32.220157Z +PROPS-END + +Revision-number: 1 +Prop-content-length: 109 +Content-length: 109 + +K 7 +svn:log +V 10 +For test. + +K 10 +svn:author +V 4 +frsn +K 8 +svn:date +V 27 +2008-04-11T11:31:10.571895Z +PROPS-END + +Node-path: bar +Node-kind: dir +Node-action: add +Prop-content-length: 73 +Content-length: 73 + +K 12 +fcm:revision +V 39 +bar3 = 3 +bar3.1 = 31 +bar3.14 = 314 + +PROPS-END + + +Node-path: baz +Node-kind: dir +Node-action: add +Prop-content-length: 75 +Content-length: 75 + +K 12 +fcm:revision +V 41 +bear = 4 + + + +bee = 6 + +spider = 8 + +mistake + +PROPS-END + + +Node-path: foo +Node-kind: dir +Node-action: add +Prop-content-length: 10 +Content-length: 10 + +PROPS-END + + diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.t new file mode 100755 index 0000000..559f370 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Keyword/Loader/VC/Revision.t @@ -0,0 +1,101 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Carp qw{croak}; +use Fcm::Keyword::Entries; +use File::Basename qw{dirname}; +use File::Spec; +use File::Temp qw{tempdir}; +use IO::File; +use IO::Pipe; +use POSIX qw{WIFEXITED}; +use Test::More (tests => 17); + +my %VALUE_OF = ( + bar => { + 'bar3' => 3, + 'bar3.1' => 31, + 'bar3.14' => 314, + }, + baz => { + 'bear' => 4, + 'bee' => 6, + 'spider' => 8, + }, +); + +main(); + +sub main { + my $class = 'Fcm::Keyword::Loader::VC::Revision'; + use_ok($class); + test_constructor($class); + test_load_to($class); +} + +################################################################################ +# Tests simple usage of the constructor +sub test_constructor { + my ($class) = @_; + my $prefix = "constructor"; + my $loader = $class->new({source => 'foo'}); + isa_ok($loader, $class); + is($loader->get_source(), 'foo', "$prefix: get_source()"); + ok($loader->load_to(), "$prefix: load_to"); # FIXME: should fail? +} + +################################################################################ +# Tests loading to an Fcm::Keyword::Entries object +sub test_load_to { + my ($class) = @_; + my $prefix = 'load to'; + my $temp_dir = tempdir(CLEANUP => 1); + my $repos = File::Spec->catfile($temp_dir, 'repos'); + WIFEXITED(system(qw{svnadmin create}, $repos)) + || croak("$repos: cannot create: $?"); + my $dump_file = File::Spec->catfile(dirname($0), 'Revision.dump'); + my $handle = IO::File->new($dump_file, 'r'); + if (!$handle) { + croak("$dump_file: cannot load: $!"); + } + my $dump = do{local $/; $handle->getline()}; + $handle->close(); + my $pipe = IO::Pipe->new(); + $pipe->writer(qw{svnadmin load -q}, $repos); + print($pipe $dump); + $pipe->close(); + if ($?) { + croak("$dump_file: cannot load: $?"); + } + my $repos_url = "file://$repos"; + my $loader = $class->new({source => $repos_url}); + my $entries = Fcm::Keyword::Entries->new(); + ok($loader->load_to($entries), "$prefix: nothing to load"); + for my $key (keys(%VALUE_OF)) { + my $url = "$repos_url/$key"; + my $loader = $class->new({source => $url}); + $loader->load_to($entries); + for my $rev_key (keys(%{$VALUE_OF{$key}})) { + my $entry = $entries->get_entry_by_key($rev_key); + if ($entry) { + is( + $entry->get_key(), + uc($rev_key), + "$prefix: by key: $rev_key", + ); + is( + $entries->get_entry_by_value($VALUE_OF{$key}{$rev_key}), + $entry, + "$prefix: by value: $rev_key: object", + ); + } + else { + fail("$prefix: by key: $rev_key"); + } + } + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Util.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Util.t new file mode 100755 index 0000000..d32d2ff --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Util.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More qw{no_plan}; + +main(); + +sub main { + use_ok('Fcm::Util'); + test_tidy_url(); +} + +################################################################################ +# Tests tidy_url +sub test_tidy_url { + my $prefix = "tidy_url"; + my %RESULT_OF = ( + '' => '', + 'foo' => 'foo', + 'foo/bar' => 'foo/bar', + 'http://foo/bar' => 'http://foo/bar', + 'http://foo/bar@1234' => 'http://foo/bar@1234', + 'http://foo/bar/@1234' => 'http://foo/bar@1234', + 'http://foo/bar/.' => 'http://foo/bar', + 'http://foo/bar/.@1234' => 'http://foo/bar@1234', + 'http://foo/bar/./@1234' => 'http://foo/bar@1234', + 'http://foo/bar/./baz' => 'http://foo/bar/baz', + 'http://foo/bar/..' => 'http://foo', + 'http://foo/bar/..@1234' => 'http://foo@1234', + 'http://foo/bar/../@1234' => 'http://foo@1234', + 'http://foo/bar/../baz' => 'http://foo/baz', + 'http://foo/bar/../.' => 'http://foo', + 'http://foo/bar/baz/../..' => 'http://foo', + ); + for my $key (sort keys(%RESULT_OF)) { + is(tidy_url($key), $RESULT_OF{$key}, "$prefix: $key"); + } +} + +# TODO: more unit tests + +__END__ diff --git a/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Util/ClassLoader.t b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Util/ClassLoader.t new file mode 100644 index 0000000..0cb6514 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/FCM/t/Fcm/Util/ClassLoader.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +################################################################################ +# A class for testing the loader +{ + package MyTestClass; + + sub new { + my ($class) = @_; + return bless(\do{my $annon_scalar}, $class); + } +} + +use Test::More qw{no_plan}; + +main(); + +sub main { + use_ok('Fcm::Util::ClassLoader'); + test_normal(); + test_bad(); +} + +################################################################################ +# Tests loading classes that should load OK +sub test_normal { + my $prefix = 'normal'; + my @CLASSES = ( + 'Fcm::CLI::Config', + 'Fcm::Exception', + 'Fcm::CLI::Config', # repeat + 'MyTestClass', + ); + for my $class (@CLASSES) { + ok(Fcm::Util::ClassLoader::load($class), "$prefix: load $class"); + } +} + +################################################################################ +# Tests loading classes that should fail +sub test_bad { + my $prefix = 'bad'; + my @CLASSES = ('Foo', 'Bar', 'Baz', 'No::Such::Class', 'Foo'); + for my $class (@CLASSES) { + eval { + Fcm::Util::ClassLoader::load($class); + }; + isa_ok($@, 'Fcm::Exception', "$prefix: load $class"); + } +} + +__END__ diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/entries b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/entries new file mode 100644 index 0000000..48082f7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/entries @@ -0,0 +1 @@ +12 diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/format b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/format new file mode 100644 index 0000000..48082f7 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/format @@ -0,0 +1 @@ +12 diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/2e/2ebbac7e8eef08cdfe34d1722c9ccc40044fb050.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/2e/2ebbac7e8eef08cdfe34d1722c9ccc40044fb050.svn-base new file mode 100644 index 0000000..5d0ca19 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/2e/2ebbac7e8eef08cdfe34d1722c9ccc40044fb050.svn-base @@ -0,0 +1,17 @@ +MODULE ioipsl +! +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +! + USE errioipsl + USE stringop + USE mathelp + USE getincom + USE calendar + USE fliocom + USE flincom + USE histcom + USE restcom +END MODULE ioipsl diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/41/4187ae0c720d2cf564779f88b8aeac4d5ff88746.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/41/4187ae0c720d2cf564779f88b8aeac4d5ff88746.svn-base new file mode 100644 index 0000000..8d8974c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/41/4187ae0c720d2cf564779f88b8aeac4d5ff88746.svn-base @@ -0,0 +1,1136 @@ +/* Generate tk script based upon config.in + * $Id$ + * + * This software is governed by the CeCILL license + * See IOIPSL/IOIPSL_License_CeCILL.txt + * + * Version 1.0 + * Eric Youngdale + * 10/95 + * + * 1996 01 04 + * Avery Pennarun - Aesthetic improvements. + * + * 1996 01 24 + * Avery Pennarun - Bugfixes and more aesthetics. + * + * 1996 03 08 + * Avery Pennarun - The int and hex config.in commands work right. + * - Choice buttons are more user-friendly. + * - Disabling a text entry line greys it out properly. + * - dep_tristate now works like in Configure. (not pretty) + * - No warnings in gcc -Wall. (Fixed some "interesting" bugs.) + * - Faster/prettier "Help" lookups. + * + * 1996 03 15 + * Avery Pennarun - Added new sed script from Axel Boldt to make help even + * faster. (Actually awk is downright slow on some machines.) + * - Fixed a bug I introduced into Choice dependencies. Thanks + * to Robert Krawitz for pointing this out. + * + * 1996 03 16 + * Avery Pennarun - basic "do_make" support added to let sound config work. + * + * 1996 03 25 + * Axel Boldt - Help now works on "choice" buttons. + * + * 1996 04 06 + * Avery Pennarun - Improved sound config stuff. (I think it actually works + * now!) + * - Window-resize-limits don't use ugly /usr/lib/tk4.0 hack. + * - int/hex work with tk3 again. (The "cget" error.) + * - Next/Prev buttons switch between menus. I can't take + * much credit for this; the code was already there, but + * ifdef'd out for some reason. It flickers a lot, but + * I suspect there's no "easy" fix for that. + * - Labels no longer highlight as you move the mouse over + * them (although you can still press them... oh well.) + * - Got rid of the last of the literal color settings, to + * help out people with mono X-Windows systems. + * (Apparently there still are some out there!) + * - Tabstops seem sensible now. + * + * 1996 04 14 + * Avery Pennarun - Reduced flicker when creating windows, even with "update + * idletasks" hack. + * + * TO DO: + * - clean up - there are useless ifdef's everywhere. + * - better comments throughout - C code generating tcl is really cryptic. + * - eliminate silly "update idletasks" hack to improve display speed and + * reduce flicker. But how? + * - make canvas contents resize with the window (good luck). + * - some way to make submenus inside of submenus (ie. Main->Networking->IP) + * (perhaps a button where the description would be) + * - make the main menu use the same tcl code as the submenus. + * - make choice and int/hex input types line up vertically with + * bool/tristate. + * - general speedups - how? The canvas seems to slow it down a lot. + * - choice buttons should default to the first menu option, rather than a + * blank. Also look up the right variable when the help button + * is pressed. + * - clean up +/- 16 confusion for enabling/disabling variables; causes + * (theoretical, at the moment) problems with dependencies. + * + */ +#include <stdio.h> +#include <unistd.h> +#include "tkparse.h" + +#ifndef TRUE +#define TRUE (1) +#endif + +#ifndef FALSE +#define FALSE (0) +#endif + +/* + * This is the total number of submenus that we have. + */ +static int tot_menu_num =0; + +/* + * Generate portion of wish script for the beginning of a submenu. + * The guts get filled in with the various options. + */ +static void start_proc(char * label, int menu_num, int flag) +{ + if( flag ) + printf("menu_option menu%d %d \"%s\"\n", menu_num, menu_num, label); + printf("proc menu%d {w title} {\n", menu_num); + printf("\tcatch {destroy $w}\n"); + printf("\ttoplevel $w -class Dialog\n"); + printf("\twm withdraw $w\n"); + printf("\tmessage $w.m -width 400 -aspect 300 -text \\\n"); + printf("\t\t\"%s\" -relief raised\n",label); + printf("\tpack $w.m -pady 10 -side top -padx 10\n"); + printf("\twm title $w \"%s\" \n\n", label); + + /* + * Attach the "Prev", "Next" and "OK" buttons at the end of the window. + */ + printf("\tset oldFocus [focus]\n"); + printf("\tframe $w.f\n"); + printf("\tbutton $w.f.back -text \"Main Menu\" \\\n" + "\t\t-width 15 -command \"destroy $w; focus $oldFocus; update_mainmenu $w\"\n"); + printf("\tbutton $w.f.next -text \"Next\" \\\n" + "\t\t-width 15 -command \" destroy $w; focus $oldFocus; menu%d .menu%d \\\"$title\\\"\"\n", + menu_num+1, menu_num+1); + if (menu_num == tot_menu_num) + printf("\t$w.f.next configure -state disabled\n"); + printf("\tbutton $w.f.prev -text \"Prev\" \\\n" + "\t\t-width 15 -command \" destroy $w; focus $oldFocus; menu%d .menu%d \\\"$title\\\"\"\n", + menu_num-1, menu_num-1); + if (1 == menu_num) + printf("\t$w.f.prev configure -state disabled\n"); + printf("\tpack $w.f.back $w.f.next $w.f.prev -side left -expand on\n"); + printf("\tpack $w.f -pady 10 -side bottom -anchor w -fill x\n"); + + /* + * Lines between canvas and other areas of the window. + */ + printf("\tframe $w.topline -relief ridge -borderwidth 2 -height 2\n"); + printf("\tpack $w.topline -side top -fill x\n\n"); + printf("\tframe $w.botline -relief ridge -borderwidth 2 -height 2\n"); + printf("\tpack $w.botline -side bottom -fill x\n\n"); + + /* + * The "config" frame contains the canvas and a scrollbar. + */ + printf("\tframe $w.config\n"); + printf("\tpack $w.config -fill y -expand on\n\n"); + printf("\tscrollbar $w.config.vscroll -command \"$w.config.canvas yview\"\n"); + printf("\tpack $w.config.vscroll -side right -fill y\n\n"); + + /* + * The scrollable canvas itself, where the real work (and mess) gets done. + */ + printf("\tcanvas $w.config.canvas -height 1\\\n" + "\t\t-relief flat -borderwidth 0 -yscrollcommand \"$w.config.vscroll set\" \\\n" + "\t\t-width [expr [winfo screenwidth .] * 1 / 2] \n"); + printf("\tframe $w.config.f\n"); + printf("\tpack $w.config.canvas -side right -fill y\n"); + + printf("\n\n"); +} + +/* + * Each proc we create needs a global declaration for any global variables we + * use. To minimize the size of the file, we set a flag each time we output + * a global declaration so we know whether we need to insert one for a + * given function or not. + */ +void clear_globalflags(struct kconfig * cfg) +{ + for(; cfg != NULL; cfg = cfg->next) + { + cfg->flags &= ~GLOBAL_WRITTEN; + } +} + +/* + * Output a "global" line for a given variable. Also include the + * call to "vfix". (If vfix is not needed, then it's fine to just printf + * a "global" line). + */ +void global(char *var) +{ + printf("\tglobal %s; vfix %s\n", var, var); +} + +/* + * This function walks the chain of conditions that we got from cond.c, + * and creates a wish conditional to enable/disable a given widget. + */ +void generate_if(struct kconfig * item, + struct condition * cond, + int menu_num, + int line_num) +{ + struct condition * ocond; + + ocond = cond; + + /* + * First write any global declarations we need for this conditional. + */ + while(cond != NULL ) + { + switch(cond->op){ + case op_variable: + global(cond->variable.str); + break; + case op_kvariable: + if(cond->variable.cfg->flags & GLOBAL_WRITTEN) break; + cond->variable.cfg->flags |= GLOBAL_WRITTEN; + global(cond->variable.cfg->optionname); + break; + default: + break; + } + cond = cond->next; + } + + /* + * Now write this option. + */ + if( (item->flags & GLOBAL_WRITTEN) == 0 + && (item->optionname != NULL) ) + { + global(item->optionname); + item->flags |= GLOBAL_WRITTEN; + } + /* + * Now generate the body of the conditional. + */ + printf("\tif {"); + cond = ocond; + while(cond != NULL ) + { + switch(cond->op){ + case op_bang: + printf(" ! "); + break; + case op_eq: + printf(" == "); + break; + case op_neq: + printf(" != "); + break; + case op_and: + case op_and1: + printf(" && "); + break; + case op_or: + printf(" || "); + break; + case op_lparen: + printf("("); + break; + case op_rparen: + printf(")"); + break; + case op_variable: + printf("$%s", cond->variable.str); + break; + case op_kvariable: + printf("$%s", cond->variable.cfg->optionname); + break; + case op_shellcmd: + printf("[exec %s]", cond->variable.str); + break; + case op_constant: + if( strcmp(cond->variable.str, "y") == 0 ) + printf("1"); + else if( strcmp(cond->variable.str, "n") == 0 ) + printf("0"); + else if( strcmp(cond->variable.str, "m") == 0 ) + printf("2"); + else + printf("\"%s\"", cond->variable.str); + break; + default: + break; + } + cond = cond->next; + } + + /* + * Now we generate what we do depending upon the value of the conditional. + * Depending upon what the token type is, there are different things + * we must do to enable/disable the given widget - this code needs to + * be closely coordinated with the widget creation procedures in header.tk. + */ + switch(item->tok) + { + case tok_define: + printf("} then { set %s %s } \n", item->optionname, item->value); + break; + case tok_menuoption: + printf("} then { .f0.x%d configure -state normal } else { .f0.x%d configure -state disabled }\n", + menu_num, menu_num); + break; + case tok_int: + case tok_hex: + printf("} then { "); + printf(".menu%d.config.f.x%d.x configure -state normal -fore [ cget .ref -foreground ]; ", menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state normal; ", menu_num, line_num); + printf("} else { "); + printf(".menu%d.config.f.x%d.x configure -state disabled -fore [ cget .ref -disabledforeground ];", menu_num, line_num ); + printf(".menu%d.config.f.x%d.l configure -state disabled;", menu_num, line_num ); + printf("}\n"); + break; + case tok_bool: +#ifdef BOOL_IS_BUTTON + /* + * If a bool is just a button, then use this definition. + */ + printf("} then { .menu%d.config.f.x%d configure -state normal } else { .menu%d.config.f.x%d configure -state disabled }\n", + menu_num, line_num, + menu_num, line_num ); +#else + /* + * If a bool is a radiobutton, then use this instead. + */ + printf("} then { "); + printf(".menu%d.config.f.x%d.y configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.n configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state normal;",menu_num, line_num); + printf("set %s [expr $%s&15];", item->optionname, item->optionname); + printf("} else { "); + printf(".menu%d.config.f.x%d.y configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.n configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state disabled;",menu_num, line_num); + printf("set %s [expr $%s|16];", item->optionname, item->optionname); + printf("}\n"); +#endif + break; + case tok_tristate: + case tok_dep_tristate: + printf("} then { "); + if( item->tok == tok_dep_tristate ) + { + global(item->depend.str); + printf("if { $%s != 1 && $%s != 0 } then {", + item->depend.str,item->depend.str); + printf(".menu%d.config.f.x%d.y configure -state disabled;",menu_num, line_num); + printf("} else {"); + printf(".menu%d.config.f.x%d.y configure -state normal;",menu_num, line_num); + printf("}; "); + } + else + { + printf(".menu%d.config.f.x%d.y configure -state normal;",menu_num, line_num); + } + + printf(".menu%d.config.f.x%d.n configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.m configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state normal;",menu_num, line_num); + /* + * Or in a bit to the variable - this causes all of the radiobuttons + * to be deselected (i.e. not be red). + */ + printf("set %s [expr $%s&15];", item->optionname, item->optionname); + printf("} else { "); + printf(".menu%d.config.f.x%d.y configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.n configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.m configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state disabled;",menu_num, line_num); + /* + * Clear the disable bit - this causes the correct radiobutton + * to appear selected (i.e. turn red). + */ + printf("set %s [expr $%s|16];", item->optionname, item->optionname); + printf("}\n"); + break; + case tok_choose: + case tok_choice: + fprintf(stderr,"Fixme\n"); + exit(0); + default: + break; + } +} + +/* + * Similar to generate_if, except we come here when generating an + * output file. Thus instead of enabling/disabling a widget, we + * need to decide whether to write out a given configuration variable + * to the output file. + */ +void generate_if_for_outfile(struct kconfig * item, + struct condition * cond) +{ + struct condition * ocond; + + /* + * First write any global declarations we need for this conditional. + */ + ocond = cond; + for(; cond != NULL; cond = cond->next ) + { + switch(cond->op){ + case op_variable: + global(cond->variable.str); + break; + case op_kvariable: + if(cond->variable.cfg->flags & GLOBAL_WRITTEN) break; + cond->variable.cfg->flags |= GLOBAL_WRITTEN; + global(cond->variable.cfg->optionname); + break; + default: + break; + } + } + + /* + * Now generate the body of the conditional. + */ + printf("\tif {"); + cond = ocond; + while(cond != NULL ) + { + switch(cond->op){ + case op_bang: + printf(" ! "); + break; + case op_eq: + printf(" == "); + break; + case op_neq: + printf(" != "); + break; + case op_and: + case op_and1: + printf(" && "); + break; + case op_or: + printf(" || "); + break; + case op_lparen: + printf("("); + break; + case op_rparen: + printf(")"); + break; + case op_variable: + printf("$%s", cond->variable.str); + break; + case op_shellcmd: + printf("[exec %s]", cond->variable.str); + break; + case op_kvariable: + printf("$%s", cond->variable.cfg->optionname); + break; + case op_constant: + if( strcmp(cond->variable.str, "y") == 0 ) + printf("1"); + else if( strcmp(cond->variable.str, "n") == 0 ) + printf("0"); + else if( strcmp(cond->variable.str, "m") == 0 ) + printf("2"); + else + printf("\"%s\"", cond->variable.str); + break; + default: + break; + } + cond = cond->next; + } + + /* + * Now we generate what we do depending upon the value of the + * conditional. Depending upon what the token type is, there are + * different things we must do write the value the given widget - + * this code needs to be closely coordinated with the widget + * creation procedures in header.tk. + */ + switch(item->tok) + { + case tok_define: + printf("} then {write_tristate $cfg $autocfg %s %s $notmod }\n", item->optionname, item->value); + break; + case tok_comment: + printf("} then {write_comment $cfg $autocfg \"%s\"}\n", item->label); + break; + case tok_dep_tristate: + printf("} then { write_tristate $cfg $autocfg %s $%s $%s } \n", + item->optionname, item->optionname, item->depend.str); + break; + case tok_tristate: + case tok_bool: + printf("} then { write_tristate $cfg $autocfg %s $%s $notmod }\n", + item->optionname, item->optionname); + break; + case tok_int: + printf("} then { write_int $cfg $autocfg %s $%s $notmod }\n", + item->optionname, item->optionname); + break; + case tok_hex: + printf("} then { write_hex $cfg $autocfg %s $%s $notmod }\n", + item->optionname, item->optionname); + break; + case tok_make: + printf("} then { do_make {%s} }\n",item->value); + break; + case tok_choose: + case tok_choice: + fprintf(stderr,"Fixme\n"); + exit(0); + default: + break; + } +} + +/* + * Generates a fragment of wish script that closes out a submenu procedure. + */ +static void end_proc(int menu_num) +{ + struct kconfig * cfg; + + printf("\n\n\n"); + printf("\tfocus $w\n"); + printf("\tupdate_menu%d $w.config.f\n", menu_num); + printf("\tglobal winx; global winy\n"); + printf("\tset winx [expr [winfo x .]+30]; set winy [expr [winfo y .]+30]\n"); + printf("\twm geometry $w +$winx+$winy\n"); + + /* + * Now that the whole window is in place, we need to wait for an "update" + * so we can tell the canvas what its virtual size should be. + * + * Unfortunately, this causes some ugly screen-flashing because the whole + * window is drawn, and then it is immediately resized. It seems + * unavoidable, though, since "frame" objects won't tell us their size + * until after an update, and "canvas" objects can't automatically pack + * around frames. Sigh. + */ + printf("\tupdate idletasks\n"); + printf("\t$w.config.canvas create window 0 0 -anchor nw -window $w.config.f\n\n"); + printf("\t$w.config.canvas configure \\\n" + "\t\t-width [expr [winfo reqwidth $w.config.f] + 1]\\\n" + "\t\t-scrollregion \"-1 -1 [expr [winfo reqwidth $w.config.f] + 1] \\\n" + "\t\t\t [expr [winfo reqheight $w.config.f] + 1]\"\n\n"); + + /* + * If the whole canvas will fit in 3/4 of the screen height, do it; + * otherwise, resize to around 1/2 the screen and let us scroll. + */ + printf("\tset winy [expr [winfo reqh $w] - [winfo reqh $w.config.canvas]]\n"); + printf("\tset scry [expr [winfo screenh $w] / 2]\n"); + printf("\tset maxy [expr [winfo screenh $w] * 3 / 4]\n"); + printf("\tset canvtotal [expr [winfo reqh $w.config.f] + 2]\n"); + printf("\tif [expr $winy + $canvtotal < $maxy] {\n" + "\t\t$w.config.canvas configure -height $canvtotal\n" + "\t} else {\n" + "\t\t$w.config.canvas configure -height [expr $scry - $winy]\n" + "\t}\n"); + + /* + * Limit the min/max window size. Height can vary, but not width, + * because of the limitations of canvas and our laziness. + */ + printf("\tupdate idletasks\n"); + printf("\twm maxsize $w [winfo width $w] [winfo screenheight $w]\n"); + printf("\twm minsize $w [winfo width $w] 100\n\n"); + printf("\twm deiconify $w\n"); + + printf("}\n\n\n"); + + /* + * Now we generate the companion procedure for the menu we just + * generated. This procedure contains all of the code to + * disable/enable widgets based upon the settings of the other + * widgets, and will be called first when the window is mapped, + * and each time one of the buttons in the window are clicked. + */ + printf("proc update_menu%d {w} {\n", menu_num); + + printf("\tupdate_define\n"); + clear_globalflags(config); + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + /* + * Skip items not for this menu, or ones having no conditions. + */ + if (cfg->menu_number != menu_num ) continue; + if (cfg->tok != tok_define) continue; + /* + * Clear all of the booleans that are defined in this menu. + */ + if( (cfg->flags & GLOBAL_WRITTEN) == 0 + && (cfg->optionname != NULL) ) + { + printf("\tglobal %s\n", cfg->optionname); + cfg->flags |= GLOBAL_WRITTEN; + printf("\tset %s 0\n", cfg->optionname); + } + + } + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + /* + * Skip items not for this menu, or ones having no conditions. + */ + if (cfg->menu_number != menu_num ) continue; + if (cfg->tok == tok_menuoption) continue; + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, menu_num, cfg->menu_line); + else + { + /* + * If this token has no conditionals, check to see whether + * it is a tristate - if so, then generate the conditional + * to enable/disable the "y" button based upon the setting + * of the option it depends upon. + */ + if(cfg->tok == tok_dep_tristate) + { + global(cfg->depend.str); + printf("\tif {$%s != 1 && $%s != 0 } then { .menu%d.config.f.x%d.y configure -state disabled } else { .menu%d.config.f.x%d.y configure -state normal}\n", + cfg->depend.str,cfg->depend.str, + menu_num, cfg->menu_line, + menu_num, cfg->menu_line); + } + } + + } + + + printf("}\n\n\n"); +} + +/* + * This function goes through and counts up the number of items in + * each submenu. If there are too many options, we need to split it + * into submenus. This function just calculates how many submenus, + * and how many items go in each submenu. + */ +static void find_menu_size(struct kconfig *cfg, + int *menu_max, + int *menu_maxlines) + +{ + struct kconfig * pnt; + int tot; + + /* + * First count up the number of options in this menu. + */ + tot = 0; + for(pnt = cfg->next; pnt; pnt = pnt->next) + { + if( pnt->tok == tok_menuoption) break; + switch (pnt->tok) + { + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + case tok_choose: + tot++; + break; + case tok_choice: + default: + break; + } + } + + *menu_max = cfg->menu_number; + *menu_maxlines = tot; +} + +/* + * This is the top level function for generating the tk script. + */ +void dump_tk_script(struct kconfig *scfg) +{ + int menu_num =0; + int menu_max =0; + int menu_min =0; + int menu_line = 0; + int menu_maxlines = 0; + struct kconfig * cfg; + struct kconfig * cfg1 = NULL; + char * menulabel; + + /* + * Start by assigning menu numbers, and submenu numbers. + */ + for(cfg = scfg;cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_menuname: + break; + case tok_menuoption: + /* + * At the start of a new menu, calculate the number of items + * we will put into each submenu so we know when to bump the + * menu number. The submenus are really no different from a + * normal menu, but the top level buttons only access the first + * of the chain of menus, and the prev/next buttons are used + * access the submenus. + */ + cfg->menu_number = ++menu_num; + find_menu_size(cfg, &menu_max, &menu_maxlines); + cfg->submenu_start = menu_num; + cfg->submenu_end = menu_max; + menu_line = 0; + break; + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + case tok_choose: + /* + * If we have overfilled the menu, then go to the next one. + */ + if( menu_line == menu_maxlines ) + { + menu_line = 0; + menu_num++; + } + cfg->menu_number = menu_num; + cfg->submenu_start = menu_min; + cfg->submenu_end = menu_max; + cfg->menu_line = menu_line++; + break; + case tok_define: + cfg->menu_number = -1; + case tok_choice: + default: + break; + }; + } + + /* + * Record this so we can set up the prev/next buttons correctly. + */ + tot_menu_num = menu_num; + + /* + * Now start generating the actual wish script that we will use. + * We need to keep track of the menu numbers of the min/max menu + * for a range of submenus so that we can correctly limit the + * prev and next buttons so that they don't go over into some other + * category. + */ + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_menuname: + printf("mainmenu_name \"%s\"\n", cfg->label); + break; + case tok_menuoption: + /* + * We are at the start of a new menu. If we had one that + * we were working on before, close it out, and then generate + * the script to start the new one. + */ + if( cfg->menu_number > 1 ) + { + end_proc(menu_num); + } + menulabel = cfg->label; + start_proc(cfg->label, cfg->menu_number, TRUE); + menu_num = cfg->menu_number; + menu_max = cfg->submenu_end; + menu_min = cfg->submenu_start; + break; + case tok_bool: + /* + * If we reached the point where we need to switch over + * to the next submenu, then bump the menu number and generate + * the code to close out the old menu and start the new one. + */ + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tbool $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + + case tok_choice: + printf("\t$w.config.f.x%d.x.menu add radiobutton -label \"%s\" -variable %s -value \"%s\" -command \"update_menu%d .menu%d.config.f\"\n", + cfg1->menu_line, + cfg->label, + cfg1->optionname, + cfg->label, + cfg1->menu_number, cfg1->menu_number); + break; + case tok_choose: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tglobal %s\n",cfg->optionname); + printf("\tminimenu $w.config.f %d %d \"%s\" %s %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname, + /* + * We rely on the fact that the first tok_choice corresponding + * to the current tok_choose is cfg->next (compare parse() in + * tkparse.c). We need its name to pick out the right help + * text from Configure.help. + */ + cfg->next->optionname); + printf("\tmenu $w.config.f.x%d.x.menu\n", cfg->menu_line); + cfg1 = cfg; + break; + case tok_tristate: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\ttristate $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + case tok_dep_tristate: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tdep_tristate $w.config.f %d %d \"%s\" %s %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname, + cfg->depend.str); + break; + case tok_int: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tint $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + case tok_hex: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\thex $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + default: + break; + } + + } + + /* + * Generate the code to close out the last menu. + */ + end_proc(menu_num); + +#ifdef ERIC_DONT_DEF + /* + * Generate the code for configuring the sound driver. Right now this + * cannot be done from the X script, but we insert the menu anyways. + */ + start_proc("Configure sound driver", ++menu_num, TRUE); +#if 0 + printf("\tdo_make -C drivers/sound config\n"); + printf("\techo check_sound_config %d\n",menu_num); +#endif + printf("\tlabel $w.config.f.m0 -bitmap error\n"); + printf("\tmessage $w.config.f.m1 -width 400 -aspect 300 -text \"The sound drivers cannot as of yet be configured via the X-based interface\" -relief raised\n"); + printf("\tpack $w.config.f.m0 $w.config.f.m1 -side top -pady 10 -expand on\n"); + /* + * Close out the last menu. + */ + end_proc(menu_num); +#endif + + /* + * The top level menu also needs an update function. When we exit a + * submenu, we may need to disable one or more of the submenus on + * the top level menu, and this procedure will ensure that things are + * correct. + */ + printf("proc update_mainmenu {w} {\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_menuoption: + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, cfg->menu_number, cfg->menu_line); + break; + default: + break; + } + } + + printf("}\n\n\n"); + +#if 0 + /* + * Generate some code to set the variables that are "defined". + */ + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + /* + * Skip items not for this menu, or ones having no conditions. + */ + if( cfg->tok != tok_define) continue; + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, menu_num, cfg->menu_line); + else + { + printf("\twrite_define %s %s\n", cfg->optionname, cfg->value); + } + + } +#endif + + /* + * Now generate code to load the default settings into the variables. + * Note that the script in tail.tk will attempt to load .config, + * which may override these settings, but that's OK. + */ + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_choice: + printf("set %s 0\n", cfg->optionname); + break; + case tok_int: + case tok_hex: + printf("set %s %s\n", cfg->optionname, cfg->value); + break; + case tok_choose: + printf("set %s \"(not set)\"\n",cfg->optionname); + default: + break; + } + } + + /* + * Next generate a function that can be called from the main menu that will + * write all of the variables out. This also serves double duty - we can + * save configuration to a file using this. + */ + printf("proc writeconfig {file1 file2} {\n"); + printf("\tset cfg [open $file1 w]\n"); + printf("\tset autocfg [open $file2 w]\n"); + printf("\tset notmod 1\n"); + printf("\tset notset 0\n"); + clear_globalflags(config); + printf("\tputs $cfg \"#\"\n"); + printf("\tputs $cfg \"# Automatically generated make config: don't edit\"\n"); + printf("\tputs $cfg \"#\"\n"); + + printf("\tputs $autocfg \"/*\"\n"); + printf("\tputs $autocfg \" * Automatically generated C config: don't edit\"\n"); + printf("\tputs $autocfg \" */\"\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_int: + case tok_hex: + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_define: + case tok_choose: + if(!(cfg->flags & GLOBAL_WRITTEN)) + { + cfg->flags |= GLOBAL_WRITTEN; + printf("\tglobal %s\n", cfg->optionname); + } + /* fall through */ + case tok_make: + case tok_comment: + if (cfg->cond != NULL ) + generate_if_for_outfile(cfg, cfg->cond); + else + { + if(cfg->tok == tok_dep_tristate) + { + printf("\tif {$%s == 0 } then {\n" + "\t\twrite_tristate $cfg $autocfg %s $notset $notmod\n" + "\t} else {\n" + "\t\twrite_tristate $cfg $autocfg %s $%s $%s\n" + "\t}\n", + cfg->depend.str, + cfg->optionname, + cfg->optionname, + cfg->optionname, + cfg->depend.str); + } + else if(cfg->tok == tok_comment) + { + printf("\twrite_comment $cfg $autocfg \"%s\"\n", cfg->label); + } +#if 0 + else if(cfg->tok == tok_define) + { + printf("\twrite_define %s %s\n", cfg->optionname, + cfg->value); + } +#endif + else if (cfg->tok == tok_choose ) + { + for(cfg1 = cfg->next; + cfg1 != NULL && cfg1->tok == tok_choice; + cfg1 = cfg1->next) + { + printf("\tif { $%s == \"%s\" } then { write_tristate $cfg $autocfg %s 1 $notmod }\n", + cfg->optionname, + cfg1->label, + cfg1->optionname); + } + } + else if (cfg->tok == tok_int ) + { + printf("\twrite_int $cfg $autocfg %s $%s $notmod\n", + cfg->optionname, + cfg->optionname); + } + else if (cfg->tok == tok_hex ) + { + printf("\twrite_hex $cfg $autocfg %s $%s $notmod\n", + cfg->optionname, + cfg->optionname); + } + else if (cfg->tok == tok_make ) + { + printf("\tdo_make {%s}\n",cfg->value); + } + else + { + printf("\twrite_tristate $cfg $autocfg %s $%s $notmod\n", + cfg->optionname, + cfg->optionname); + } + } + break; + default: + break; + } + } + printf("\tclose $cfg\n"); + printf("\tclose $autocfg\n"); + printf("}\n\n\n"); + + /* + * Finally write a simple function that updates the master choice + * variable depending upon what values were loaded from a .config + * file. + */ + printf("proc clear_choices { } {\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_choose ) continue; + for(cfg1 = cfg->next; + cfg1 != NULL && cfg1->tok == tok_choice; + cfg1 = cfg1->next) + { + printf("\tglobal %s; set %s 0\n",cfg1->optionname,cfg1->optionname); + } + } + printf("}\n\n\n"); + + printf("proc update_choices { } {\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_choose ) continue; + printf("\tglobal %s\n", cfg->optionname); + for(cfg1 = cfg->next; + cfg1 != NULL && cfg1->tok == tok_choice; + cfg1 = cfg1->next) + { + printf("\tglobal %s\n", cfg1->optionname); + printf("\tif { $%s == 1 } then { set %s \"%s\" }\n", + cfg1->optionname, + cfg->optionname, + cfg1->label); + } + } + printf("}\n\n\n"); + + printf("proc update_define { } {\n"); + clear_globalflags(config); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_define ) continue; + printf("\tglobal %s; set %s 0\n", cfg->optionname, cfg->optionname); + cfg->flags |= GLOBAL_WRITTEN; + } + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_define ) continue; + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, -1, 0); + else + { + printf("\tset %s %s\n", + cfg->optionname, cfg->value); + } + } + printf("}\n\n\n"); + /* + * That's it. We are done. The output of this file will have header.tk + * prepended and tail.tk appended to create an executable wish script. + */ +} diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/41/41b15bd8c29c889cc282bf4a9b7edcf1357ed0f1.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/41/41b15bd8c29c889cc282bf4a9b7edcf1357ed0f1.svn-base new file mode 100644 index 0000000..4428fff --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/41/41b15bd8c29c889cc282bf4a9b7edcf1357ed0f1.svn-base @@ -0,0 +1,3122 @@ +MODULE mathelp +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- + USE errioipsl,ONLY : ipslerr + USE stringop +!- + PRIVATE + PUBLIC :: mathop,moycum,buildop +!- + INTERFACE mathop + MODULE PROCEDURE mathop_r11,mathop_r21,mathop_r31 + END INTERFACE +!- +!- Variables used to detect and identify the operations +!- + CHARACTER(LEN=80),SAVE :: & + & seps='( ) , + - / * ^', ops = '+ - * / ^', mima = 'min max' + CHARACTER(LEN=250),SAVE :: & + & funcs = 'sin cos tan asin acos atan exp log sqrt chs abs '& + & //'cels kelv deg rad gather scatter fill coll undef only ident' + CHARACTER(LEN=120),SAVE :: & + & indexfu = 'gather, scatter, fill, coll, undef, only' +!--------------------------------------------------------------------- +CONTAINS +!=== +SUBROUTINE buildop (c_str,ex_topps,topp,fill_val,opps,scal,nbops) +!--------------------------------------------------------------------- +!- This subroutine decomposes the input string in the elementary +!- functions which need to be applied to the vector of data. +!- This vector is represented by X in the string. +!- This subroutine is the driver of the decomposition and gets +!- the time operation but then call decoop for the other operations +!- +!- INPUT +!- +!- c_str : String containing the operations +!- ex_toops : Time operations that can be expected within the string +!- fill_val : +!- +!- OUTPUT +!- +!- topp : Time operation +!- opps : +!- scal : +!- nbops : +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: c_str,ex_topps + CHARACTER(LEN=*),INTENT(OUT) :: topp + CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps + REAL,INTENT(IN) :: fill_val + REAL,DIMENSION(:),INTENT(OUT) :: scal + INTEGER,INTENT(OUT) :: nbops +!- + CHARACTER(LEN=LEN(c_str)) :: str,new_str + INTEGER :: leng,ind_opb,ind_clb +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning' +!- + str = c_str + leng = LEN_TRIM(str) + IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN + str = str(2:leng-1) + leng = leng-2 + ENDIF +!- + IF (check) & + & WRITE(*,*) 'buildop : Starting to test the various options' +!- + IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN + IF (check) WRITE(*,*) 'buildop : Time operation only' + nbops = 0 + topp = str(1:leng) + ELSE + IF (check) THEN + WRITE(*,*) 'buildop : Time operation and something else' + ENDIF +!-- + ind_opb = INDEX(str(1:leng),'(') + IF (ind_opb > 0) THEN + IF (INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN + IF (check) THEN + WRITE(*,'(2a)') & + & ' buildop : Extract time operation from : ',str + ENDIF + topp = str(1:ind_opb-1) + ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.) + new_str = str(ind_opb+1:ind_clb-1) + IF (check) THEN + WRITE(*,'(2a,2I3)') & + & ' buildop : Call decoop ',new_str,ind_opb,ind_clb + ENDIF + CALL decoop (new_str,fill_val,opps,scal,nbops) + ELSE + CALL ipslerr(3,'buildop', & + & 'time operation does not exist',str(1:ind_opb-1),' ') + ENDIF + ELSE + CALL ipslerr(3,'buildop', & + & 'some long operation exists but wihout parenthesis', & + & str(1:leng),' ') + ENDIF + ENDIF +!- + IF (check) THEN + DO leng=1,nbops + WRITE(*,*) & + & 'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng) + ENDDO + ENDIF +!--------------------- +END SUBROUTINE buildop +!=== +SUBROUTINE decoop (pstr,fill_val,opps,scal,nbops) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: pstr + REAL,INTENT(IN) :: fill_val + CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps + REAL,DIMENSION(:),INTENT(OUT) :: scal + INTEGER,INTENT(OUT) :: nbops +!- + CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char + INTEGER,DIMENSION(2) :: f_pos,s_pos + CHARACTER(LEN=20) :: opp_str,scal_str + CHARACTER(LEN=LEN(pstr)) :: str + INTEGER :: nbsep,nbops_max,xpos,leng,ppos,epos,int_tmp + CHARACTER(LEN=3) :: tl,dl + CHARACTER(LEN=10) :: fmt +!- + LOGICAL :: check = .FALSE.,prio +!--------------------------------------------------------------------- + IF (check) WRITE(*,'(2A)') ' decoop : Incoming string : ',pstr +!- + str = pstr; nbops = 0; +!- + CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos) + IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep +!- + nbops_max = min(SIZE(opps),SIZE(scal)) +!- + DO WHILE (nbsep > 0) + IF (nbops >= nbops_max) THEN + CALL ipslerr(3,'decoop','Expression too complex',TRIM(str),' ') + ENDIF +!-- + xpos = INDEX(str,'X') + leng = LEN_TRIM(str) + nbops = nbops+1 +!-- + IF (check) THEN + WRITE(*,*) 'decoop : str -> ',TRIM(str) + WRITE(*,*) 'decoop : nbops -> ',nbops + WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2) + WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2) + ENDIF +!--- +!-- Start the analysis of the syntax. 3 types of constructs +!-- are recognized. They are scanned sequentialy +!--- + IF (nbsep == 1) THEN + IF (check) WRITE(*,*) 'decoop : Only one operation' + IF (INDEX(ops,f_char(1)) > 0) THEN +!------ Type : scal+X + IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN + opp_str = f_char(1)//'I' + ELSE + opp_str = f_char(1) + ENDIF + scal_str = str(s_pos(1)+1:f_pos(1)-1) + str = 'X' + ELSE IF (INDEX(ops,f_char(2)) > 0) THEN +!------ Type : X+scal + opp_str = f_char(2) + scal_str = str(f_pos(2)+1:s_pos(2)-1) + str = 'X' + ELSE + CALL ipslerr(3,'decoop', & + & 'Unknown operations of type X+scal',f_char(1),pstr) + ENDIF + ELSE + IF (check) WRITE(*,*) 'decoop : More complex operation' + IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN +!------ Type : sin(X) + opp_str = str(s_pos(1)+1:f_pos(1)-1) + scal_str = '?' + str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng) + ELSE IF ( (f_char(1) == '(' .AND. f_char(2) == ',')& + & .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN +!------ Type : max(X,scal) or max(scal,X) + IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN +!-------- Type : max(X,scal) + opp_str = str(f_pos(1)-3:f_pos(1)-1) + scal_str = str(f_pos(2)+1:s_pos(2)-1) + str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng) + ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN +!-------- Type : max(scal,X) + opp_str = str(s_pos(1)-3:s_pos(1)-1) + scal_str = str(s_pos(1)+1:f_pos(1)-1) + str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng) + ELSE + CALL ipslerr(3,'decoop','Syntax error 1',str,' ') + ENDIF + ELSE + prio = (f_char(2) == '*').OR.(f_char(2) == '^') + IF ( (INDEX(ops,f_char(1)) > 0) & + & .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN +!-------- Type : ... scal+X ... + IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN + opp_str = f_char(1)//'I' + ELSE + opp_str = f_char(1) + ENDIF + scal_str = str(s_pos(1)+1:f_pos(1)-1) + str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng) + ELSE IF ( (INDEX(ops,f_char(2)) > 0) & + & .AND.(f_pos(2)-xpos == 1) ) THEN +!-------- Type : ... X+scal ... + opp_str = f_char(2) + scal_str = str(f_pos(2)+1:s_pos(2)-1) + str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng) + ELSE + CALL ipslerr(3,'decoop','Syntax error 2',str,' ') + ENDIF + ENDIF + ENDIF +!--- + IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',TRIM(str) +!--- +!-- Now that the different components of the operation are identified +!-- we transform them into what is going to be used in the program +!--- + IF (INDEX(scal_str,'?') > 0) THEN + IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN + opps(nbops) = opp_str(1:LEN_TRIM(opp_str)) + scal(nbops) = fill_val + ELSE + CALL ipslerr(3,'decoop', & + & 'Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ') + ENDIF + ELSE + leng = LEN_TRIM(opp_str) + IF (INDEX(mima,opp_str(1:leng)) > 0) THEN + opps(nbops) = 'fu'//opp_str(1:leng) + ELSE + IF (INDEX(opp_str(1:leng),'+') > 0) THEN + opps(nbops) = 'add' + ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN + opps(nbops) = 'subi' + ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN + opps(nbops) = 'sub' + ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN + opps(nbops) = 'mult' + ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN + opps(nbops) = 'div' + ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN + opps(nbops) = 'divi' + ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN + opps(nbops) = 'power' + ELSE + CALL ipslerr(3,'decoop', & + & 'Unknown operation',opp_str(1:leng),' ') + ENDIF + ENDIF +!----- + leng = LEN_TRIM(scal_str) + ppos = INDEX(scal_str,'.') + epos = INDEX(scal_str,'e') + IF (epos == 0) epos = INDEX(scal_str,'E') +!----- +!---- Try to catch a few errors +!----- + IF (INDEX(ops,scal_str) > 0) THEN + CALL ipslerr(3,'decoop', & + & 'Strange scalar you have here ',scal_str,pstr) + ENDIF + IF (epos > 0) THEN + WRITE(tl,'(I3.3)') leng + WRITE(dl,'(I3.3)') epos-ppos-1 + fmt='(e'//tl//'.'//dl//')' + READ(scal_str,fmt) scal(nbops) + ELSE IF (ppos > 0) THEN + WRITE(tl,'(I3.3)') leng + WRITE(dl,'(I3.3)') leng-ppos + fmt='(f'//tl//'.'//dl//')' + READ(scal_str,fmt) scal(nbops) + ELSE + WRITE(tl,'(I3.3)') leng + fmt = '(I'//tl//')' + READ(scal_str,fmt) int_tmp + scal(nbops) = REAL(int_tmp) + ENDIF + ENDIF + IF (check) WRITE(*,*) 'decoop : Finished interpretation' + CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos) + ENDDO +!-------------------- +END SUBROUTINE decoop +!=== +SUBROUTINE findsep (str,nbsep,f_char,f_pos,s_char,s_pos) +!--------------------------------------------------------------------- +!- Subroutine finds all separators in a given string +!- It returns the following information about str : +!- f_char : The first separation character +!- (1 for before and 2 for after) +!- f_pos : The position of the first separator +!- s_char : The second separation character +!- (1 for before and 2 for after) +!- s_pos : The position of the second separator +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(INOUT) :: str + INTEGER :: nbsep + CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char + INTEGER,DIMENSION(2) :: f_pos,s_pos +!- + CHARACTER(LEN=10) :: str_tmp + LOGICAL :: f_found,s_found + INTEGER :: ind,xpos,leng,i +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) 'findsep : call cleanstr: ',TRIM(str) +!- + CALL cleanstr(str) +!- + IF (check) WRITE(*,*) 'findsep : out of cleanstr: ',TRIM(str) +!- + xpos = INDEX(str,'X') + leng = LEN_TRIM(str) +!- + f_pos(1:2) = (/ 0,leng+1 /) + f_char(1:2) = (/ '?','?' /) + s_pos(1:2) = (/ 0,leng+1 /) + s_char(1:2) = (/ '?','?' /) +!- + nbsep = 0 +!- + f_found = .FALSE. + s_found = .FALSE. + IF (xpos > 1) THEN + DO i=xpos-1,1,-1 + ind = INDEX(seps,str(i:i)) + IF (ind > 0) THEN + IF (.NOT.f_found) THEN + f_char(1) = str(i:i) + f_pos(1) = i + nbsep = nbsep+1 + f_found = .TRUE. + ELSE IF (.NOT.s_found) THEN + s_char(1) = str(i:i) + s_pos(1) = i + nbsep = nbsep+1 + s_found = .TRUE. + ENDIF + ENDIF + ENDDO + ENDIF +!- + f_found = .FALSE. + s_found = .FALSE. + IF (xpos < leng) THEN + DO i=xpos+1,leng + ind = INDEX(seps,str(i:i)) + IF (ind > 0) THEN + IF (.NOT.f_found) THEN + f_char(2) = str(i:i) + f_pos(2) = i + nbsep = nbsep+1 + f_found = .TRUE. + ELSE IF (.NOT.s_found) THEN + s_char(2) = str(i:i) + s_pos(2) = i + nbsep = nbsep+1 + s_found = .TRUE. + ENDIF + ENDIF + ENDDO + ENDIF +!- + IF (nbsep > 4) THEN + WRITE(str_tmp,'("number :",I3)') nbsep + CALL ipslerr(3,'findsep', & + & 'How can I find that many separators',str_tmp,TRIM(str)) + ENDIF +!- + IF (check) WRITE(*,*) 'Finished findsep : ',nbsep,leng +!--------------------- +END SUBROUTINE findsep +!=== +SUBROUTINE cleanstr(str) +!--------------------------------------------------------------------- +!- We clean up the string by taking out the extra () and puting +!- everything in lower case except for the X describing the variable +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(INOUT) :: str +!- + INTEGER :: ind,leng,ic,it + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + leng = LEN_TRIM(str) + CALL strlowercase(str) +!- + ind = INDEX(str,'x') + IF (check) THEN + WRITE (*,*) 'cleanstr 1.0 : ind = ',ind, & +& ' str = ',str(1:leng),'---' + ENDIF +!- +! If the character before the x is not a letter then we can assume +! that it is the variable and promote it to a capital letter +!- + DO WHILE (ind > 0) + ic = 0 + IF (ind > 1) ic = IACHAR(str(ind-1:ind-1)) + IF (ic < 97 .OR. ic > 122) THEN + str(ind:ind) = 'X' + ENDIF + it = INDEX(str(ind+1:leng),'x') + IF (it > 0) THEN + ind = ind+it + ELSE + ind = it + ENDIF + ENDDO +!- + IF (check) WRITE (*,*) 'cleanstr 2.0 : str = ',str(1:leng),'---' +!- + IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN + str = str(2:leng-1) + ENDIF +!- + IF (check) WRITE (*,*) 'cleanstr 3.0 : str = ',str(1:leng),'---' +!- + leng = LEN_TRIM(str) + ind = INDEX(str,'((X))') + IF (ind > 0) THEN + str=str(1:ind-1)//'(X)'//str(ind+5:leng)//' ' + ENDIF +!- + IF (check) WRITE (*,*) 'cleanstr 4.0 : str = ',str(1:leng),'---' +!- + leng = LEN_TRIM(str) + ind = INDEX(str,'(X)') + IF (ind > 0 .AND. ind+3 < leng) THEN + IF ( (INDEX(seps,str(ind-1:ind-1)) > 0) & + & .AND. (INDEX(seps,str(ind+3:ind+3)) > 0) ) THEN + str=str(1:ind-1)//'X'//str(ind+3:leng)//' ' + ENDIF + ENDIF +!- + IF (check) WRITE (*,*) 'cleanstr 5.0 : str = ',str(1:leng),'---' +!- + leng = LEN_TRIM(str) + ind = INDEX(str(1:leng),' ') + DO WHILE (ind > 0) + str=str(1:ind-1)//str(ind+1:leng)//' ' + leng = LEN_TRIM(str) + ind = INDEX(str(1:leng),' ') + ENDDO +!- + IF (check) WRITE (*,*) 'cleanstr 6.0 : str = ',str(1:leng),'---' +!---------------------- +END SUBROUTINE cleanstr +!=== +!=== +SUBROUTINE mathop_r11 & + & (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) +!--------------------------------------------------------------------- +!- This subroutines gives an interface to the various operation +!- which are allowed. The interface is general enough to allow its use +!- for other cases. +!- +!- INPUT +!- +!- fun : function to be applied to the vector of data +!- nb : Length of input vector +!- work_in : Input vector of data (REAL) +!- miss_val : The value of the missing data flag (it has to be a +!- maximum value, in f90 : huge( a real )) +!- nb_index : Length of index vector +!- nindex : Vector of indices +!- scal : A scalar value for vector/scalar operations +!- nb_max : maximum length of output vector +!- +!- OUTPUT +!- +!- nb_max : Actual length of output variable +!- work_out : Output vector after the operation was applied +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: fun + INTEGER :: nb,nb_max,nb_index + INTEGER :: nindex(nb_index) + REAL :: work_in(nb),scal,miss_val + REAL :: work_out(nb_max) +!- + INTEGER :: ierr +!- + INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS +!--------------------------------------------------------------------- + ierr = 0 +!- + IF (scal >= miss_val-1.) THEN + IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN + SELECT CASE (fun) + CASE('sin') + ierr = ma_sin_r11(nb,work_in,nb_max,work_out) + CASE('cos') + ierr = ma_cos_r11(nb,work_in,nb_max,work_out) + CASE('tan') + ierr = ma_tan_r11(nb,work_in,nb_max,work_out) + CASE('asin') + ierr = ma_asin_r11(nb,work_in,nb_max,work_out) + CASE('acos') + ierr = ma_acos_r11(nb,work_in,nb_max,work_out) + CASE('atan') + ierr = ma_atan_r11(nb,work_in,nb_max,work_out) + CASE('exp') + ierr = ma_exp_r11(nb,work_in,nb_max,work_out) + CASE('log') + ierr = ma_log_r11(nb,work_in,nb_max,work_out) + CASE('sqrt') + ierr = ma_sqrt_r11(nb,work_in,nb_max,work_out) + CASE('chs') + ierr = ma_chs_r11(nb,work_in,nb_max,work_out) + CASE('abs') + ierr = ma_abs_r11(nb,work_in,nb_max,work_out) + CASE('cels') + ierr = ma_cels_r11(nb,work_in,nb_max,work_out) + CASE('kelv') + ierr = ma_kelv_r11(nb,work_in,nb_max,work_out) + CASE('deg') + ierr = ma_deg_r11(nb,work_in,nb_max,work_out) + CASE('rad') + ierr = ma_rad_r11(nb,work_in,nb_max,work_out) + CASE('ident') + ierr = ma_ident_r11(nb,work_in,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and no indexing', & + & 'but still unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a simple function',fun,' ') + ENDIF + ELSE + SELECT CASE (fun) + CASE('gather') + ierr = ma_fugath_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('scatter') + IF (nb_index > nb) THEN + work_out(1:nb_max) = miss_val + ierr=1 + ELSE + ierr = ma_fuscat_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + ENDIF + CASE('coll') + ierr = ma_fucoll_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('fill') + ierr = ma_fufill_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('undef') + ierr = ma_fuundef_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('only') + ierr = ma_fuonly_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and indexing',& + & 'was requested but with unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop_r11", & + & 'Error while executing an indexing function',fun,' ') + ENDIF + ENDIF + ELSE + SELECT CASE (fun) + CASE('fumin') + ierr = ma_fumin_r11(nb,work_in,scal,nb_max,work_out) + CASE('fumax') + ierr = ma_fumax_r11(nb,work_in,scal,nb_max,work_out) + CASE('add') + ierr = ma_add_r11(nb,work_in,scal,nb_max,work_out) + CASE('subi') + ierr = ma_subi_r11(nb,work_in,scal,nb_max,work_out) + CASE('sub') + ierr = ma_sub_r11(nb,work_in,scal,nb_max,work_out) + CASE('mult') + ierr = ma_mult_r11(nb,work_in,scal,nb_max,work_out) + CASE('div') + ierr = ma_div_r11(nb,work_in,scal,nb_max,work_out) + CASE('divi') + ierr = ma_divi_r11(nb,work_in,scal,nb_max,work_out) + CASE('power') + ierr = ma_power_r11(nb,work_in,scal,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'Unknown operation with a scalar',fun,' ') + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a scalar function',fun,' ') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE mathop_r11 +!- +!=== FUNCTIONS (only one argument) +!- +INTEGER FUNCTION ma_sin_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = SIN(x(i)) + ENDDO +!- + nbo = nb + ma_sin_r11 = 0 +!---------------------- +END FUNCTION ma_sin_r11 +!=== +INTEGER FUNCTION ma_cos_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = COS(x(i)) + ENDDO +!- + nbo = nb + ma_cos_r11 = 0 +!---------------------- +END FUNCTION ma_cos_r11 +!=== +INTEGER FUNCTION ma_tan_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = TAN(x(i)) + ENDDO +!- + nbo = nb + ma_tan_r11 = 0 +!---------------------- +END FUNCTION ma_tan_r11 +!=== +INTEGER FUNCTION ma_asin_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ASIN(x(i)) + ENDDO +!- + nbo = nb + ma_asin_r11 = 0 +!----------------------- +END FUNCTION ma_asin_r11 +!=== +INTEGER FUNCTION ma_acos_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ACOS(x(i)) + ENDDO +!- + nbo = nb + ma_acos_r11 = 0 +!----------------------- +END FUNCTION ma_acos_r11 +!=== +INTEGER FUNCTION ma_atan_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ATAN(x(i)) + ENDDO +!- + nbo = nb + ma_atan_r11 = 0 +!----------------------- +END FUNCTION ma_atan_r11 +!=== +INTEGER FUNCTION ma_exp_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = EXP(x(i)) + ENDDO +!- + nbo = nb + ma_exp_r11 = 0 +!---------------------- +END FUNCTION ma_exp_r11 +!=== +INTEGER FUNCTION ma_log_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = log(x(i)) + ENDDO +!- + nbo = nb + ma_log_r11 = 0 +!---------------------- +END FUNCTION ma_log_r11 +!=== +INTEGER FUNCTION ma_sqrt_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = SQRT(x(i)) + ENDDO +!- + nbo = nb + ma_sqrt_r11 = 0 +!----------------------- +END FUNCTION ma_sqrt_r11 +!=== +INTEGER FUNCTION ma_abs_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ABS(x(i)) + ENDDO +!- + nbo = nb + ma_abs_r11 = 0 +!---------------------- +END FUNCTION ma_abs_r11 +!=== +INTEGER FUNCTION ma_chs_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*(-1.) + ENDDO +!- + nbo = nb + ma_chs_r11 = 0 +!---------------------- +END FUNCTION ma_chs_r11 +!=== +INTEGER FUNCTION ma_cels_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)-273.15 + ENDDO +!- + nbo = nb + ma_cels_r11 = 0 +!----------------------- +END FUNCTION ma_cels_r11 +!=== +INTEGER FUNCTION ma_kelv_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)+273.15 + ENDDO +!- + nbo = nb + ma_kelv_r11 = 0 +!----------------------- +END FUNCTION ma_kelv_r11 +!=== +INTEGER FUNCTION ma_deg_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*57.29577951 + ENDDO +!- + nbo = nb + ma_deg_r11 = 0 +!----------------------- +END FUNCTION ma_deg_r11 +!=== +INTEGER FUNCTION ma_rad_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*0.01745329252 + ENDDO +!- + nbo = nb + ma_rad_r11 = 0 +!---------------------- +END FUNCTION ma_rad_r11 +!=== +INTEGER FUNCTION ma_ident_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i) + ENDDO +!- + nbo = nb + ma_ident_r11 = 0 +!------------------------ +END FUNCTION ma_ident_r11 +!- +!=== OPERATIONS (two argument) +!- +INTEGER FUNCTION ma_add_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)+s + ENDDO +!- + nbo = nb + ma_add_r11 = 0 +!----------------------- + END FUNCTION ma_add_r11 +!=== +INTEGER FUNCTION ma_sub_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)-s + ENDDO +!- + nbo = nb + ma_sub_r11 = 0 +!---------------------- +END FUNCTION ma_sub_r11 +!=== +INTEGER FUNCTION ma_subi_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = s-x(i) + ENDDO +!- + nbo = nb + ma_subi_r11 = 0 +!----------------------- +END FUNCTION ma_subi_r11 +!=== +INTEGER FUNCTION ma_mult_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*s + ENDDO +!- + nbo = nb + ma_mult_r11 = 0 +!----------------------- +END FUNCTION ma_mult_r11 +!=== +INTEGER FUNCTION ma_div_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)/s + ENDDO +!- + nbo = nb + ma_div_r11 = 0 +!----------------------- + END FUNCTION ma_div_r11 +!=== +INTEGER FUNCTION ma_divi_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = s/x(i) + ENDDO +!- + nbo = nb + ma_divi_r11 = 0 +!----------------------- +END FUNCTION ma_divi_r11 +!=== +INTEGER FUNCTION ma_power_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)**s + ENDDO +!- + nbo = nb + ma_power_r11 = 0 +!----------------------- +END FUNCTION ma_power_r11 +!=== +INTEGER FUNCTION ma_fumin_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = MIN(x(i),s) + ENDDO +!- + nbo = nb + ma_fumin_r11 = 0 +!------------------------ +END FUNCTION ma_fumin_r11 +!=== +INTEGER FUNCTION ma_fumax_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = MAX(x(i),s) + ENDDO +!- + nbo = nb + ma_fumax_r11 = 0 +!------------------------ +END FUNCTION ma_fumax_r11 +!=== +INTEGER FUNCTION ma_fuscat_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ii,ipos +!--------------------------------------------------------------------- + ma_fuscat_r11 = 0 +!- + y(1:nbo) = miss_val +!- + IF (nbi <= nb) THEN + ipos = 0 + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + ipos = ipos+1 + y(ind(i)) = x(ipos) + ELSE + IF (ind(i) > nbo) ma_fuscat_r11 = ma_fuscat_r11+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fuscat_r11 = ma_fuscat_r11+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fuscat_r11 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuscat_r11 +!=== +INTEGER FUNCTION ma_fugath_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fugath_r11 = 0 + y(1:nbo) = miss_val + ipos = 0 + DO i=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(i) > 0) THEN + ipos = ipos+1 + y(ipos) = x(ind(i)) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fugath_r11 = ma_fugath_r11+1 + ENDIF + ENDDO + ELSE + ma_fugath_r11 = 1 + ENDIF +!- + nbo = ipos +!------------------------- +END FUNCTION ma_fugath_r11 +!=== +INTEGER FUNCTION ma_fufill_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ii,ipos +!--------------------------------------------------------------------- + ma_fufill_r11 = 0 +!- + IF (nbi <= nb) THEN + ipos = 0 + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + ipos = ipos+1 + y(ind(i)) = x(ipos) + ELSE + IF (ind(i) > nbo) ma_fufill_r11 = ma_fufill_r11+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fufill_r11 = ma_fufill_r11+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fufill_r11 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fufill_r11 +!=== +INTEGER FUNCTION ma_fucoll_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fucoll_r11 = 0 + ipos = 0 + DO i=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(i) > 0) THEN + ipos = ipos+1 + y(ipos) = x(ind(i)) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fucoll_r11 = ma_fucoll_r11+1 + ENDIF + ENDDO + ELSE + ma_fucoll_r11 = 1 + ENDIF +!- + nbo = ipos +!------------------------- +END FUNCTION ma_fucoll_r11 +!=== +INTEGER FUNCTION ma_fuundef_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + IF (nbi <= nbo .AND. nbo == nb) THEN + ma_fuundef_r11 = 0 + DO i=1,nbo + y(i) = x(i) + ENDDO + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + y(ind(i)) = miss_val + ELSE + IF (ind(i) > nbo) ma_fuundef_r11 = ma_fuundef_r11+1 + ENDIF + ENDDO + ELSE + ma_fuundef_r11 = 1 + ENDIF +!-------------------------- +END FUNCTION ma_fuundef_r11 +!=== +INTEGER FUNCTION ma_fuonly_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + IF ( (nbi <= nbo).AND.(nbo == nb) & + & .AND.ALL(ind(1:nbi) <= nbo) ) THEN + ma_fuonly_r11 = 0 + y(1:nbo) = miss_val + DO i=1,nbi + IF (ind(i) > 0) THEN + y(ind(i)) = x(ind(i)) + ENDIF + ENDDO + ELSE + ma_fuonly_r11 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuonly_r11 +!=== +!=== +SUBROUTINE mathop_r21 & + & (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) +!--------------------------------------------------------------------- +!- This subroutines gives an interface to the various operations +!- which are allowed. The interface is general enough to allow its use +!- for other cases. +!- +!- INPUT +!- +!- fun : function to be applied to the vector of data +!- nb : Length of input vector +!- work_in : Input vector of data (REAL) +!- miss_val : The value of the missing data flag (it has to be a +!- maximum value, in f90 : huge( a real )) +!- nb_index : Length of index vector +!- nindex : Vector of indices +!- scal : A scalar value for vector/scalar operations +!- nb_max : maximum length of output vector +!- +!- OUTPUT +!- +!- nb_max : Actual length of output variable +!- work_out : Output vector after the operation was applied +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: fun + INTEGER :: nb(2),nb_max,nb_index + INTEGER :: nindex(nb_index) + REAL :: work_in(nb(1),nb(2)),scal,miss_val + REAL :: work_out(nb_max) +!- + INTEGER :: ierr +!- + INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS +!--------------------------------------------------------------------- + ierr = 0 +!- + IF (scal >= miss_val-1.) THEN + IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN + SELECT CASE (fun) + CASE('sin') + ierr = ma_sin_r21(nb,work_in,nb_max,work_out) + CASE('cos') + ierr = ma_cos_r21(nb,work_in,nb_max,work_out) + CASE('tan') + ierr = ma_tan_r21(nb,work_in,nb_max,work_out) + CASE('asin') + ierr = ma_asin_r21(nb,work_in,nb_max,work_out) + CASE('acos') + ierr = ma_acos_r21(nb,work_in,nb_max,work_out) + CASE('atan') + ierr = ma_atan_r21(nb,work_in,nb_max,work_out) + CASE('exp') + ierr = ma_exp_r21(nb,work_in,nb_max,work_out) + CASE('log') + ierr = ma_log_r21(nb,work_in,nb_max,work_out) + CASE('sqrt') + ierr = ma_sqrt_r21(nb,work_in,nb_max,work_out) + CASE('chs') + ierr = ma_chs_r21(nb,work_in,nb_max,work_out) + CASE('abs') + ierr = ma_abs_r21(nb,work_in,nb_max,work_out) + CASE('cels') + ierr = ma_cels_r21(nb,work_in,nb_max,work_out) + CASE('kelv') + ierr = ma_kelv_r21(nb,work_in,nb_max,work_out) + CASE('deg') + ierr = ma_deg_r21(nb,work_in,nb_max,work_out) + CASE('rad') + ierr = ma_rad_r21(nb,work_in,nb_max,work_out) + CASE('ident') + ierr = ma_ident_r21(nb,work_in,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and no indexing', & + & 'but still unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a simple function',fun,' ') + ENDIF + ELSE + SELECT CASE (fun) + CASE('gather') + ierr = ma_fugath_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('scatter') + IF (nb_index > (nb(1)*nb(2)) ) THEN + work_out(1:nb_max) = miss_val + ierr=1 + ELSE + ierr = ma_fuscat_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + ENDIF + CASE('coll') + ierr = ma_fucoll_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('fill') + ierr = ma_fufill_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('undef') + ierr = ma_fuundef_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('only') + ierr = ma_fuonly_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and indexing', & + & 'was requested but with unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop_r21", & + & 'Error while executing an indexing function',fun,' ') + ENDIF + ENDIF + ELSE + SELECT CASE (fun) + CASE('fumin') + ierr = ma_fumin_r21(nb,work_in,scal,nb_max,work_out) + CASE('fumax') + ierr = ma_fumax_r21(nb,work_in,scal,nb_max,work_out) + CASE('add') + ierr = ma_add_r21(nb,work_in,scal,nb_max,work_out) + CASE('subi') + ierr = ma_subi_r21(nb,work_in,scal,nb_max,work_out) + CASE('sub') + ierr = ma_sub_r21(nb,work_in,scal,nb_max,work_out) + CASE('mult') + ierr = ma_mult_r21(nb,work_in,scal,nb_max,work_out) + CASE('div') + ierr = ma_div_r21(nb,work_in,scal,nb_max,work_out) + CASE('divi') + ierr = ma_divi_r21(nb,work_in,scal,nb_max,work_out) + CASE('power') + ierr = ma_power_r21(nb,work_in,scal,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'Unknown operation with a scalar',fun,' ') + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a scalar function',fun,' ') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE mathop_r21 +!- +!=== FUNCTIONS (only one argument) +!- +INTEGER FUNCTION ma_sin_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SIN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_sin_r21 = 0 +!---------------------- +END FUNCTION ma_sin_r21 +!=== +INTEGER FUNCTION ma_cos_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = COS(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_cos_r21 = 0 +!---------------------- +END FUNCTION ma_cos_r21 +!=== +INTEGER FUNCTION ma_tan_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = TAN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_tan_r21 = 0 +!---------------------- +END FUNCTION ma_tan_r21 +!=== + INTEGER FUNCTION ma_asin_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ASIN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_asin_r21 = 0 +!----------------------- +END FUNCTION ma_asin_r21 +!=== +INTEGER FUNCTION ma_acos_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ACOS(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_acos_r21 = 0 +!----------------------- +END FUNCTION ma_acos_r21 +!=== +INTEGER FUNCTION ma_atan_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ATAN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_atan_r21 = 0 +!----------------------- +END FUNCTION ma_atan_r21 +!=== +INTEGER FUNCTION ma_exp_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = EXP(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_exp_r21 = 0 +!---------------------- +END FUNCTION ma_exp_r21 +!=== +INTEGER FUNCTION ma_log_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = LOG(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_log_r21 = 0 +!---------------------- +END FUNCTION ma_log_r21 +!=== +INTEGER FUNCTION ma_sqrt_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SQRT(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_sqrt_r21 = 0 +!----------------------- +END FUNCTION ma_sqrt_r21 +!=== +INTEGER FUNCTION ma_abs_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ABS(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_abs_r21 = 0 +!---------------------- +END FUNCTION ma_abs_r21 +!=== +INTEGER FUNCTION ma_chs_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*(-1.) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_chs_r21 = 0 +!---------------------- +END FUNCTION ma_chs_r21 +!=== +INTEGER FUNCTION ma_cels_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)-273.15 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_cels_r21 = 0 +!----------------------- +END FUNCTION ma_cels_r21 +!=== +INTEGER FUNCTION ma_kelv_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)+273.15 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_kelv_r21 = 0 +!----------------------- +END FUNCTION ma_kelv_r21 +!=== +INTEGER FUNCTION ma_deg_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*57.29577951 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_deg_r21 = 0 +!---------------------- +END FUNCTION ma_deg_r21 +!=== +INTEGER FUNCTION ma_rad_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*0.01745329252 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_rad_r21 = 0 +!---------------------- +END FUNCTION ma_rad_r21 +!=== +INTEGER FUNCTION ma_ident_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_ident_r21 = 0 +!------------------------ +END FUNCTION ma_ident_r21 +!- +!=== OPERATIONS (two argument) +!- +INTEGER FUNCTION ma_add_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)+s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_add_r21 = 0 +!---------------------- +END FUNCTION ma_add_r21 +!=== +INTEGER FUNCTION ma_sub_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)-s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_sub_r21 = 0 +!---------------------- +END FUNCTION ma_sub_r21 +!=== +INTEGER FUNCTION ma_subi_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s-x(i,j) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_subi_r21 = 0 +!----------------------- +END FUNCTION ma_subi_r21 +!=== +INTEGER FUNCTION ma_mult_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_mult_r21 = 0 +!----------------------- +END FUNCTION ma_mult_r21 +!=== +INTEGER FUNCTION ma_div_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)/s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_div_r21 = 0 +!---------------------- +END FUNCTION ma_div_r21 +!=== +INTEGER FUNCTION ma_divi_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s/x(i,j) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_divi_r21 = 0 +!----------------------- +END FUNCTION ma_divi_r21 +!=== +INTEGER FUNCTION ma_power_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j) ** s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_power_r21 = 0 +!------------------------ +END FUNCTION ma_power_r21 +!=== +INTEGER FUNCTION ma_fumin_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MIN(x(i,j),s) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_fumin_r21 = 0 +!------------------------ +END FUNCTION ma_fumin_r21 +!=== +INTEGER FUNCTION ma_fumax_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MAX(x(i,j),s) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_fumax_r21 = 0 +!------------------------ +END FUNCTION ma_fumax_r21 +!=== +INTEGER FUNCTION ma_fuscat_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ii,ipos +!--------------------------------------------------------------------- + ma_fuscat_r21 = 0 +!- + y(1:nbo) = miss_val +!- + IF (nbi <= nb(1)*nb(2)) THEN + ipos = 0 + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + j = ((ipos-1)/nb(1))+1 + i = (ipos-(j-1)*nb(1)) + y(ind(ij)) = x(i,j) + ELSE + IF (ind(ij) > nbo) ma_fuscat_r21 = ma_fuscat_r21+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fuscat_r21 = ma_fuscat_r21+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fuscat_r21 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuscat_r21 +!=== +INTEGER FUNCTION ma_fugath_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fugath_r21 = 0 + y(1:nbo) = miss_val + ipos = 0 + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + j = ((ind(ij)-1)/nb(1))+1 + i = (ind(ij)-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fugath_r21 = ma_fugath_r21+1 + ENDIF + ENDDO + ELSE + ma_fugath_r21 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fugath_r21 +!=== +INTEGER FUNCTION ma_fufill_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ii,ipos +!--------------------------------------------------------------------- + ma_fufill_r21 = 0 +!- + IF (nbi <= nb(1)*nb(2)) THEN + ipos = 0 + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + j = ((ipos-1)/nb(1))+1 + i = (ipos-(j-1)*nb(1)) + y(ind(ij)) = x(i,j) + ELSE + IF (ind(ij) > nbo) ma_fufill_r21 = ma_fufill_r21+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fufill_r21 = ma_fufill_r21+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fufill_r21 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fufill_r21 +!=== +INTEGER FUNCTION ma_fucoll_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fucoll_r21 = 0 + ipos = 0 + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + j = ((ind(ij)-1)/nb(1))+1 + i = (ind(ij)-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fucoll_r21 = ma_fucoll_r21+1 + ENDIF + ENDDO + ELSE + ma_fucoll_r21 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fucoll_r21 +!=== +INTEGER FUNCTION ma_fuundef_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + IF (nbi <= nbo .AND. nbo == nb(1)*nb(2)) THEN + ma_fuundef_r21 = 0 + DO ij=1,nbo + j = ((ij-1)/nb(1))+1 + i = (ij-(j-1)*nb(1)) + y(ij) = x(i,j) + ENDDO + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + y(ind(i)) = miss_val + ELSE + IF (ind(i) > nbo) ma_fuundef_r21 = ma_fuundef_r21+1 + ENDIF + ENDDO + ELSE + ma_fuundef_r21 = 1 + ENDIF +!-------------------------- +END FUNCTION ma_fuundef_r21 +!=== +INTEGER FUNCTION ma_fuonly_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + IF ( (nbi <= nbo).AND.(nbo == nb(1)*nb(2)) & + & .AND.ALL(ind(1:nbi) <= nbo) ) THEN + ma_fuonly_r21 = 0 + y(1:nbo) = miss_val + DO ij=1,nbi + IF (ind(ij) > 0) THEN + j = ((ind(ij)-1)/nb(1))+1 + i = (ind(ij)-(j-1)*nb(1)) + y(ind(ij)) = x(i,j) + ENDIF + ENDDO + ELSE + ma_fuonly_r21 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuonly_r21 +!=== +!=== +SUBROUTINE mathop_r31 & + & (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) +!--------------------------------------------------------------------- +!- This subroutines gives an interface to the various operations +!- which are allowed. The interface is general enough to allow its use +!- for other cases. +!- +!- INPUT +!- +!- fun : function to be applied to the vector of data +!- nb : Length of input vector +!- work_in : Input vector of data (REAL) +!- miss_val : The value of the missing data flag (it has to be a +!- maximum value, in f90 : huge( a real )) +!- nb_index : Length of index vector +!- nindex : Vector of indices +!- scal : A scalar value for vector/scalar operations +!- nb_max : maximum length of output vector +!- +!- OUTPUT +!- +!- nb_max : Actual length of output variable +!- work_out : Output vector after the operation was applied +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: fun + INTEGER :: nb(3),nb_max,nb_index + INTEGER :: nindex(nb_index) + REAL :: work_in(nb(1),nb(2),nb(3)),scal,miss_val + REAL :: work_out(nb_max) +!- + INTEGER :: ierr +!- + INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS +!--------------------------------------------------------------------- + ierr = 0 +!- + IF (scal >= miss_val-1.) THEN + IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN + SELECT CASE (fun) + CASE('sin') + ierr = ma_sin_r31(nb,work_in,nb_max,work_out) + CASE('cos') + ierr = ma_cos_r31(nb,work_in,nb_max,work_out) + CASE('tan') + ierr = ma_tan_r31(nb,work_in,nb_max,work_out) + CASE('asin') + ierr = ma_asin_r31(nb,work_in,nb_max,work_out) + CASE('acos') + ierr = ma_acos_r31(nb,work_in,nb_max,work_out) + CASE('atan') + ierr = ma_atan_r31(nb,work_in,nb_max,work_out) + CASE('exp') + ierr = ma_exp_r31(nb,work_in,nb_max,work_out) + CASE('log') + ierr = ma_log_r31(nb,work_in,nb_max,work_out) + CASE('sqrt') + ierr = ma_sqrt_r31(nb,work_in,nb_max,work_out) + CASE('chs') + ierr = ma_chs_r31(nb,work_in,nb_max,work_out) + CASE('abs') + ierr = ma_abs_r31(nb,work_in,nb_max,work_out) + CASE('cels') + ierr = ma_cels_r31(nb,work_in,nb_max,work_out) + CASE('kelv') + ierr = ma_kelv_r31(nb,work_in,nb_max,work_out) + CASE('deg') + ierr = ma_deg_r31(nb,work_in,nb_max,work_out) + CASE('rad') + ierr = ma_rad_r31(nb,work_in,nb_max,work_out) + CASE('ident') + ierr = ma_ident_r31(nb,work_in,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and no indexing', & + & 'but still unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a simple function',fun,' ') + ENDIF + ELSE + SELECT CASE (fun) + CASE('gather') + ierr = ma_fugath_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('scatter') + IF (nb_index > (nb(1)*nb(2)*nb(3))) THEN + work_out(1:nb_max) = miss_val + ierr=1 + ELSE + ierr = ma_fuscat_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + ENDIF + CASE('coll') + ierr = ma_fucoll_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('fill') + ierr = ma_fufill_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('undef') + ierr = ma_fuundef_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('only') + ierr = ma_fuonly_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and indexing', & + & 'was requested but with unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop_r31", & + & 'Error while executing an indexing function',fun,' ') + ENDIF + ENDIF + ELSE + SELECT CASE (fun) + CASE('fumin') + ierr = ma_fumin_r31(nb,work_in,scal,nb_max,work_out) + CASE('fumax') + ierr = ma_fumax_r31(nb,work_in,scal,nb_max,work_out) + CASE('add') + ierr = ma_add_r31(nb,work_in,scal,nb_max,work_out) + CASE('subi') + ierr = ma_subi_r31(nb,work_in,scal,nb_max,work_out) + CASE('sub') + ierr = ma_sub_r31(nb,work_in,scal,nb_max,work_out) + CASE('mult') + ierr = ma_mult_r31(nb,work_in,scal,nb_max,work_out) + CASE('div') + ierr = ma_div_r31(nb,work_in,scal,nb_max,work_out) + CASE('divi') + ierr = ma_divi_r31(nb,work_in,scal,nb_max,work_out) + CASE('power') + ierr = ma_power_r31(nb,work_in,scal,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'Unknown operation with a scalar',fun,' ') + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a scalar function',fun,' ') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE mathop_r31 +!- +!=== FUNCTIONS (only one argument) +!- +INTEGER FUNCTION ma_sin_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SIN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_sin_r31 = 0 +!---------------------- +END FUNCTION ma_sin_r31 +!=== +INTEGER FUNCTION ma_cos_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = COS(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_cos_r31 = 0 +!---------------------- +END FUNCTION ma_cos_r31 +!=== +INTEGER FUNCTION ma_tan_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = TAN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_tan_r31 = 0 +!---------------------- +END FUNCTION ma_tan_r31 +!=== +INTEGER FUNCTION ma_asin_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ASIN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_asin_r31 = 0 +!----------------------- +END FUNCTION ma_asin_r31 +!=== +INTEGER FUNCTION ma_acos_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ACOS(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_acos_r31 = 0 +!----------------------- +END FUNCTION ma_acos_r31 +!=== +INTEGER FUNCTION ma_atan_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ATAN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_atan_r31 = 0 +!----------------------- + END FUNCTION ma_atan_r31 +!=== +INTEGER FUNCTION ma_exp_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = EXP(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_exp_r31 = 0 +!---------------------- +END FUNCTION ma_exp_r31 +!=== +INTEGER FUNCTION ma_log_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = LOG(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_log_r31 = 0 +!---------------------- +END FUNCTION ma_log_r31 +!=== +INTEGER FUNCTION ma_sqrt_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SQRT(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_sqrt_r31 = 0 +!----------------------- +END FUNCTION ma_sqrt_r31 +!=== +INTEGER FUNCTION ma_abs_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ABS(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_abs_r31 = 0 +!---------------------- +END FUNCTION ma_abs_r31 +!=== +INTEGER FUNCTION ma_chs_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*(-1.) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_chs_r31 = 0 +!---------------------- +END FUNCTION ma_chs_r31 +!=== +INTEGER FUNCTION ma_cels_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)-273.15 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_cels_r31 = 0 +!----------------------- +END FUNCTION ma_cels_r31 +!=== +INTEGER FUNCTION ma_kelv_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)+273.15 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_kelv_r31 = 0 +!----------------------- + END FUNCTION ma_kelv_r31 +!=== +INTEGER FUNCTION ma_deg_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*57.29577951 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_deg_r31 = 0 +!---------------------- +END FUNCTION ma_deg_r31 +!=== +INTEGER FUNCTION ma_rad_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*0.01745329252 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_rad_r31 = 0 +!---------------------- +END FUNCTION ma_rad_r31 +!=== +INTEGER FUNCTION ma_ident_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_ident_r31 = 0 +!------------------------ +END FUNCTION ma_ident_r31 +!- +!=== OPERATIONS (two argument) +!- +INTEGER FUNCTION ma_add_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)+s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_add_r31 = 0 +!---------------------- +END FUNCTION ma_add_r31 +!=== +INTEGER FUNCTION ma_sub_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)-s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_sub_r31 = 0 +!---------------------- +END FUNCTION ma_sub_r31 +!=== +INTEGER FUNCTION ma_subi_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s-x(i,j,k) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_subi_r31 = 0 +!----------------------- +END FUNCTION ma_subi_r31 +!=== +INTEGER FUNCTION ma_mult_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_mult_r31 = 0 +!----------------------- +END FUNCTION ma_mult_r31 +!=== +INTEGER FUNCTION ma_div_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)/s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_div_r31 = 0 +!---------------------- +END FUNCTION ma_div_r31 +!=== +INTEGER FUNCTION ma_divi_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s/x(i,j,k) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_divi_r31 = 0 +!----------------------- +END FUNCTION ma_divi_r31 +!=== +INTEGER FUNCTION ma_power_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)**s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_power_r31 = 0 +!------------------------ +END FUNCTION ma_power_r31 +!=== +INTEGER FUNCTION ma_fumin_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MIN(x(i,j,k),s) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_fumin_r31 = 0 +!------------------------ +END FUNCTION ma_fumin_r31 +!=== +INTEGER FUNCTION ma_fumax_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MAX(x(i,j,k),s) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_fumax_r31 = 0 +!------------------------ +END FUNCTION ma_fumax_r31 +!=== +INTEGER FUNCTION ma_fuscat_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ii,ipos,ipp,isb +!--------------------------------------------------------------------- + ma_fuscat_r31 = 0 +!- + y(1:nbo) = miss_val +!- + IF (nbi <= nb(1)*nb(2)*nb(3)) THEN + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + k = ((ipos-1)/isb)+1 + ipp = ipos-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ind(ij)) = x(i,j,k) + ELSE + IF (ind(ij) > nbo) ma_fuscat_r31 = ma_fuscat_r31+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fuscat_r31 = ma_fuscat_r31+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fuscat_r31 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuscat_r31 +!=== +INTEGER FUNCTION ma_fugath_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipos,ipp,isb +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fugath_r31 = 0 + y(1:nbo) = miss_val + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + k = ((ind(ij)-1)/isb)+1 + ipp = ind(ij)-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j,k) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fugath_r31 = ma_fugath_r31+1 + ENDIF + ENDDO + ELSE + ma_fugath_r31 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fugath_r31 +!=== +INTEGER FUNCTION ma_fufill_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ii,ipos,ipp,isb +!--------------------------------------------------------------------- + ma_fufill_r31 = 0 + IF (nbi <= nb(1)*nb(2)*nb(3)) THEN + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + k = ((ipos-1)/isb)+1 + ipp = ipos-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ind(ij)) = x(i,j,k) + ELSE + IF (ind(ij) > nbo) ma_fufill_r31 = ma_fufill_r31+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fufill_r31 = ma_fufill_r31+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fufill_r31 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fufill_r31 +!=== +INTEGER FUNCTION ma_fucoll_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipos,ipp,isb +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fucoll_r31 = 0 + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + k = ((ind(ij)-1)/isb)+1 + ipp = ind(ij)-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j,k) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fucoll_r31 = ma_fucoll_r31+1 + ENDIF + ENDDO + ELSE + ma_fucoll_r31 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fucoll_r31 +!=== +INTEGER FUNCTION ma_fuundef_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipp,isb +!--------------------------------------------------------------------- + IF (nbi <= nbo .AND. nbo == nb(1)*nb(2)*nb(3)) THEN + ma_fuundef_r31 = 0 + isb = nb(1)*nb(2) + DO ij=1,nbo + k = ((ij-1)/isb)+1 + ipp = ij-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ij) = x(i,j,k) + ENDDO + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + y(ind(i)) = miss_val + ELSE + IF (ind(i) > nbo) ma_fuundef_r31 = ma_fuundef_r31+1 + ENDIF + ENDDO + ELSE + ma_fuundef_r31 = 1 + ENDIF +!-------------------------- +END FUNCTION ma_fuundef_r31 +!=== +INTEGER FUNCTION ma_fuonly_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipp,isb +!--------------------------------------------------------------------- + IF ( (nbi <= nbo).AND.(nbo == nb(1)*nb(2)*nb(3)) & + & .AND.ALL(ind(1:nbi) <= nbo) ) THEN + ma_fuonly_r31 = 0 + y(1:nbo) = miss_val + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ind(ij) > 0) THEN + k = ((ind(ij)-1)/isb)+1 + ipp = ind(ij)-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ind(ij)) = x(i,j,k) + ENDIF + ENDDO + ELSE + ma_fuonly_r31 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuonly_r31 +!=== +SUBROUTINE moycum (opp,np,px,py,pwx) +!--------------------------------------------------------------------- +!- Does time operations +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: opp + INTEGER :: np + REAL,DIMENSION(:) :: px,py + INTEGER :: pwx +!--------------------------------------------------------------------- + IF (pwx /= 0) THEN + IF (opp == 'ave') THEN + px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1) + ELSE IF (opp == 't_sum') THEN + px(1:np)=px(1:np)+py(1:np) + ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN + px(1:np)=MIN(px(1:np),py(1:np)) + ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN + px(1:np)=MAX(px(1:np),py(1:np)) + ELSE + CALL ipslerr(3,"moycum",'Unknown time operation',opp,' ') + ENDIF + ELSE + IF (opp == 'l_min') THEN + px(1:np)=MIN(px(1:np),py(1:np)) + ELSE IF (opp == 'l_max') THEN + px(1:np)=MAX(px(1:np),py(1:np)) + ELSE + px(1:np)=py(1:np) + ENDIF + ENDIF +!-------------------- +END SUBROUTINE moycum +!=== +!----------------- +END MODULE mathelp diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/4f/4f858cb9d503d42469584fa471e5922f65a3db65.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/4f/4f858cb9d503d42469584fa471e5922f65a3db65.svn-base new file mode 100644 index 0000000..f2777cc --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/4f/4f858cb9d503d42469584fa471e5922f65a3db65.svn-base @@ -0,0 +1,546 @@ +/* parser config.in + * $Id$ + * + * This software is governed by the CeCILL license + * See IOIPSL/IOIPSL_License_CeCILL.txt + * + * Version 1.0 + * Eric Youngdale + * 10/95 + * + * The general idea here is that we want to parse a config.in file and + * from this, we generate a wish script which gives us effectively the + * same functionality that the original config.in script provided. + * + * This task is split roughly into 3 parts. The first parse is the parse + * of the input file itself. The second part is where we analyze the + * #ifdef clauses, and attach a linked list of tokens to each of the + * menu items. In this way, each menu item has a complete list of + * dependencies that are used to enable/disable the options. + * The third part is to take the configuration database we have build, + * and build the actual wish script. + * + * This file contains the code to further process the conditions from + * the "ifdef" clauses. + * + * The conditions are assumed to be one of the following formats + * + * simple_condition:= "$VARIABLE" == y/n/m + * simple_condition:= "$VARIABLE != y/n/m + * + * simple_condition -a simple_condition + * + * If the input condition contains '(' or ')' it would screw us up, but for now + * this is not a problem. + */ +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include "tkparse.h" + + +/* + * Walk a condition chain and invert it so that the logical result is + * inverted. + */ +static void invert_condition(struct condition * cnd) +{ + /* + * This is simple. Just walk through the list, and invert + * all of the operators. + */ + for(;cnd; cnd = cnd->next) + { + switch(cnd->op) + { + case op_and: + cnd->op = op_or; + break; + case op_or: + /* + * This is not turned into op_and - we need to keep track + * of what operators were used here since we have an optimization + * later on to remove duplicate conditions, and having + * inverted ors in there would make it harder if we did not + * distinguish an inverted or from an and we inserted because + * of nested ifs. + */ + cnd->op = op_and1; + break; + case op_neq: + cnd->op = op_eq; + break; + case op_eq: + cnd->op = op_neq; + break; + default: + break; + } + } +} + +/* + * Walk a condition chain, and free the memory associated with it. + */ +static void free_condition(struct condition * cnd) +{ + struct condition * next; + for(;cnd; cnd = next) + { + next = cnd->next; + + if( cnd->variable.str != NULL ) + free(cnd->variable.str); + + free(cnd); + } +} + +/* + * Walk all of the conditions, and look for choice values. Convert + * the tokens into something more digestible. + */ +void fix_choice_cond() +{ + struct condition * cond; + struct condition * cond2; + struct kconfig * cfg; + char tmpbuf[10]; + + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + if( cfg->cond == NULL ) + { + continue; + } + + for(cond = cfg->cond; cond != NULL; cond = cond->next) + { + if( cond->op != op_kvariable ) + continue; + + if( cond->variable.cfg->tok != tok_choice ) + continue; + + /* + * Look ahead for what we are comparing this to. There should + * be one operator in between. + */ + cond2 = cond->next->next; + strcpy(tmpbuf, cond->variable.cfg->label); + + if( strcmp(cond2->variable.str, "y") == 0 ) + { + cond->variable.cfg = cond->variable.cfg->choice_label; + cond2->variable.str = strdup(tmpbuf); + } + else + { + fprintf(stderr,"Ooops\n"); + exit(0); + } + } + + } +} + +/* + * Walk the stack of conditions, and clone all of them with "&&" operators + * gluing them together. The conditions from each level of the stack + * are wrapped in parenthesis so as to guarantee that the results + * are logically correct. + */ +struct condition * get_token_cond(struct condition ** cond, int depth) +{ + int i; + struct condition * newcond; + struct condition * tail; + struct condition * new; + struct condition * ocond; + struct kconfig * cfg; + + newcond = tail = NULL; + for(i=0; i<depth; i++, cond++) + { + /* + * First insert the left parenthesis + */ + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_lparen; + if( tail == NULL ) + { + newcond = tail = new; + } + else + { + tail->next = new; + tail = new; + } + + /* + * Now duplicate the chain. + */ + ocond = *cond; + for(;ocond != NULL; ocond = ocond->next) + { + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = ocond->op; + if( ocond->variable.str != NULL ) + { + if( ocond->op == op_variable ) + { + /* + * Search for structure to insert here. + */ + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_bool + && cfg->tok != tok_int + && cfg->tok != tok_hex + && cfg->tok != tok_tristate + && cfg->tok != tok_choice + && cfg->tok != tok_dep_tristate) + { + continue; + } + if( strcmp(cfg->optionname, ocond->variable.str) == 0) + { + new->variable.cfg = cfg; + new->op = op_kvariable; + break; + } + } + if( cfg == NULL ) + { + new->variable.str = strdup(ocond->variable.str); + } + } + else + { + new->variable.str = strdup(ocond->variable.str); + } + } + tail->next = new; + tail = new; + } + + /* + * Next insert the left parenthesis + */ + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_rparen; + tail->next = new; + tail = new; + + /* + * Insert an and operator, if we have another condition. + */ + if( i < depth - 1 ) + { + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_and; + tail->next = new; + tail = new; + } + + } + + return newcond; +} + +/* + * Walk a single chain of conditions and clone it. These are assumed + * to be created/processed by get_token_cond in a previous pass. + */ +struct condition * get_token_cond_frag(struct condition * cond, + struct condition ** last) +{ + struct condition * newcond; + struct condition * tail; + struct condition * new; + struct condition * ocond; + + newcond = tail = NULL; + + /* + * Now duplicate the chain. + */ + for(ocond = cond;ocond != NULL; ocond = ocond->next) + { + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = ocond->op; + new->variable.cfg = ocond->variable.cfg; + if( tail == NULL ) + { + newcond = tail = new; + } + else + { + tail->next = new; + tail = new; + } + } + + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_and; + tail->next = new; + tail = new; + + *last = tail; + return newcond; +} + +/* + * Walk through the if conditionals and maintain a chain. + */ +void fix_conditionals(struct kconfig * scfg) +{ + int depth = 0; + int i; + struct kconfig * cfg; + struct kconfig * cfg1; + struct condition * conditions[25]; + struct condition * cnd; + struct condition * cnd1; + struct condition * cnd2; + struct condition * cnd3; + struct condition * newcond; + struct condition * last; + + /* + * Start by walking the chain. Every time we see an ifdef, push + * the condition chain on the stack. When we see an "else", we invert + * the condition at the top of the stack, and when we see an "endif" + * we free all of the memory for the condition at the top of the stack + * and remove the condition from the top of the stack. + * + * For any other type of token (i.e. a bool), we clone a new condition chain + * by anding together all of the conditions that are currently stored on + * the stack. In this way, we have a correct representation of whatever + * conditions govern the usage of each option. + */ + memset(conditions, 0, sizeof(conditions)); + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + switch(cfg->tok) + { + case tok_if: + /* + * Push this condition on the stack, and nuke the token + * representing the ifdef, since we no longer need it. + */ + conditions[depth] = cfg->cond; + depth++; + cfg->tok = tok_nop; + cfg->cond = NULL; + break; + case tok_else: + /* + * For an else, we just invert the condition at the top of + * the stack. This is done in place with no reallocation + * of memory taking place. + */ + invert_condition(conditions[depth-1]); + cfg->tok = tok_nop; + break; + case tok_fi: + depth--; + free_condition(conditions[depth]); + conditions[depth] = NULL; + cfg->tok = tok_nop; + break; + case tok_comment: + case tok_define: + case tok_menuoption: + case tok_bool: + case tok_tristate: + case tok_int: + case tok_hex: + case tok_choice: + case tok_make: + /* + * We need to duplicate the chain of conditions and attach them to + * this token. + */ + cfg->cond = get_token_cond(&conditions[0], depth); + break; + case tok_dep_tristate: + /* + * Same as tok_tristate et al except we have a temporary + * conditional. (Sort of a hybrid tok_if, tok_tristate, tok_fi + * option) + */ + conditions[depth] = cfg->cond; + depth++; + cfg->cond = get_token_cond(&conditions[0], depth); + depth--; + free_condition(conditions[depth]); + conditions[depth] = NULL; + default: + break; + } + } + + /* + * Fix any conditions involving the "choice" operator. + */ + fix_choice_cond(); + + /* + * Walk through and see if there are multiple options that control the + * same kvariable. If there are we need to treat them a little bit + * special. + */ + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + switch(cfg->tok) + { + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + for(cfg1=cfg;cfg1 != NULL; cfg1 = cfg1->next) + { + switch(cfg1->tok) + { + case tok_define: + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + if( strcmp(cfg->optionname, cfg1->optionname) == 0) + { + cfg->flags |= CFG_DUP; + cfg1->flags |= CFG_DUP; + } + break; + default: + break; + } + } + break; + default: + break; + } + } + + /* + * Now go through the list, and every time we see a kvariable, check + * to see whether it also has some dependencies. If so, then + * append it to our list. The reason we do this is that we might have + * option CONFIG_FOO which is only used if CONFIG_BAR is set. It may + * turn out that in config.in that the default value for CONFIG_BAR is + * set to "y", but that CONFIG_BAR is not enabled because CONFIG_XYZZY + * is not set. The current condition chain does not reflect this, but + * we can fix this by searching for the tokens that this option depends + * upon and cloning the conditions and merging them with the list. + */ + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + /* + * Search for a token that has a condition list. + */ + if(cfg->cond == NULL) continue; + for(cnd = cfg->cond; cnd; cnd=cnd->next) + { + /* + * Now search the condition list for a known configuration variable + * that has conditions of its own. + */ + if(cnd->op != op_kvariable) continue; + if(cnd->variable.cfg->cond == NULL) continue; + + if(cnd->variable.cfg->flags & CFG_DUP) continue; + /* + * OK, we have some conditions to append to cfg. Make a clone + * of the conditions, + */ + newcond = get_token_cond_frag(cnd->variable.cfg->cond, &last); + + /* + * Finally, we splice it into our list. + */ + last->next = cfg->cond; + cfg->cond = newcond; + + } + } + + /* + * There is a strong possibility that we have duplicate conditions + * in here. It would make the script more efficient and readable to + * remove these. Here is where we assume here that there are no + * parenthesis in the input script. + */ + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + /* + * Search for configuration options that have conditions. + */ + if(cfg->cond == NULL) continue; + for(cnd = cfg->cond; cnd; cnd=cnd->next) + { + /* + * Search for a left parenthesis. + */ + if(cnd->op != op_lparen) continue; + for(cnd1 = cnd->next; cnd1; cnd1=cnd1->next) + { + /* + * Search after the previous left parenthesis, and try + * and find a second left parenthesis. + */ + if(cnd1->op != op_lparen) continue; + + /* + * Now compare the next 5 tokens to see if they are + * identical. We are looking for two chains that + * are like: '(' $VARIABLE operator constant ')'. + */ + cnd2 = cnd; + cnd3 = cnd1; + for(i=0; i<5; i++, cnd2=cnd2->next, cnd3=cnd3->next) + { + if(!cnd2 || !cnd3) break; + if(cnd2->op != cnd3->op) break; + if(i == 1 && (cnd2->op != op_kvariable + || cnd2->variable.cfg != cnd3->variable.cfg) ) break; + if(i==2 && cnd2->op != op_eq && cnd2->op != op_neq) break; + if(i == 3 && cnd2->op != op_constant && + strcmp(cnd2->variable.str, cnd3->variable.str) != 0) + break; + if(i==4 && cnd2->op != op_rparen) break; + } + /* + * If these match, and there is an and gluing these together, + * then we can nuke the second one. + */ + if(i==5 && ((cnd3 && cnd3->op == op_and) + ||(cnd2 && cnd2->op == op_and))) + { + /* + * We have a duplicate. Nuke 5 ops. + */ + cnd3 = cnd1; + for(i=0; i<5; i++, cnd3=cnd3->next) + { + cnd3->op = op_nuked; + } + /* + * Nuke the and that glues the conditions together. + */ + if(cnd3 && cnd3->op == op_and) cnd3->op = op_nuked; + else if(cnd2 && cnd2->op == op_and) cnd2->op = op_nuked; + } + } + } + } +} diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/78/788574a284f5ca188de4ef7bc90163f0d3833ea0.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/78/788574a284f5ca188de4ef7bc90163f0d3833ea0.svn-base new file mode 100644 index 0000000..938943b --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/78/788574a284f5ca188de4ef7bc90163f0d3833ea0.svn-base @@ -0,0 +1,215 @@ +MODULE errioipsl +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg +!- + INTEGER :: n_l=6, ilv_cur=0, ilv_max=0 + LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE. +!- +!=== +CONTAINS +!=== +SUBROUTINE ipslnlf (new_number,old_number) +!!-------------------------------------------------------------------- +!! The "ipslnlf" routine allows to know and modify +!! the current logical number for the messages. +!! +!! SUBROUTINE ipslnlf (new_number,old_number) +!! +!! Optional INPUT argument +!! +!! (I) new_number : new logical number of the file +!! +!! Optional OUTPUT argument +!! +!! (I) old_number : current logical number of the file +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(IN) :: new_number + INTEGER,OPTIONAL,INTENT(OUT) :: old_number +!--------------------------------------------------------------------- + IF (PRESENT(old_number)) THEN + old_number = n_l + ENDIF + IF (PRESENT(new_number)) THEN + n_l = new_number + ENDIF +!--------------------- +END SUBROUTINE ipslnlf +!=== +SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!! The "ipslerr" routine +!! allows to handle the messages to the user. +!! +!! INPUT +!! +!! plev : Category of message to be reported to the user +!! 1 = Note to the user +!! 2 = Warning to the user +!! 3 = Fatal error +!! pcname : Name of subroutine which has called ipslerr +!! pstr1 +!! pstr2 : Strings containing the explanations to the user +!! pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + ilv_cur = plev + ilv_max = MAX(ilv_max,plev) + WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3) + ENDIF + IF ( (plev == 3).AND.lact_mode) THEN + WRITE(n_l,'("Fatal error from IOIPSL. STOP in ipslerr with code")') + STOP 1 + ENDIF +!--------------------- +END SUBROUTINE ipslerr +!=== +SUBROUTINE ipslerr_act (new_mode,old_mode) +!!-------------------------------------------------------------------- +!! The "ipslerr_act" routine allows to know and modify +!! the current "action mode" for the error messages, +!! and reinitialize the error level values. +!! +!! SUBROUTINE ipslerr_act (new_mode,old_mode) +!! +!! Optional INPUT argument +!! +!! (I) new_mode : new error action mode +!! .TRUE. -> STOP in case of fatal error +!! .FALSE. -> CONTINUE in case of fatal error +!! +!! Optional OUTPUT argument +!! +!! (I) old_mode : current error action mode +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_mode + LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode +!--------------------------------------------------------------------- + IF (PRESENT(old_mode)) THEN + old_mode = lact_mode + ENDIF + IF (PRESENT(new_mode)) THEN + lact_mode = new_mode + ENDIF + ilv_cur = 0 + ilv_max = 0 +!------------------------- +END SUBROUTINE ipslerr_act +!=== +SUBROUTINE ipslerr_inq (current_level,maximum_level) +!!-------------------------------------------------------------------- +!! The "ipslerr_inq" routine allows to know +!! the current level of the error messages +!! and the maximum level encountered since the +!! last call to "ipslerr_act". +!! +!! SUBROUTINE ipslerr_inq (current_level,maximum_level) +!! +!! Optional OUTPUT argument +!! +!! (I) current_level : current error level +!! (I) maximum_level : maximum error level +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level +!--------------------------------------------------------------------- + IF (PRESENT(current_level)) THEN + current_level = ilv_cur + ENDIF + IF (PRESENT(maximum_level)) THEN + maximum_level = ilv_max + ENDIF +!------------------------- +END SUBROUTINE ipslerr_inq +!=== +SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!- INPUT +!- plev : Category of message to be reported to the user +!- 1 = Note to the user +!- 2 = Warning to the user +!- 3 = Fatal error +!- pcname : Name of subroutine which has called histerr +!- pstr1 +!- pstr2 : String containing the explanations to the user +!- pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + WRITE(*,'(" ")') + WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(*,'(" --> ",A)') pstr1 + WRITE(*,'(" --> ",A)') pstr2 + WRITE(*,'(" --> ",A)') pstr3 + ENDIF + IF (plev == 3) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE histerr +!=== +SUBROUTINE ipsldbg (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "ipsldbg" routine +!! allows to activate or deactivate the debug, +!! and to know the current status of the debug. +!! +!! SUBROUTINE ipsldbg (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the debug +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the debug +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = ioipsl_debug + ENDIF + IF (PRESENT(new_status)) THEN + ioipsl_debug = new_status + ENDIF +!--------------------- +END SUBROUTINE ipsldbg +!=== +!------------------- +END MODULE errioipsl diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/7c/7c9811077d5ceb530eb843fd87b7a2fbf5f40409.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/7c/7c9811077d5ceb530eb843fd87b7a2fbf5f40409.svn-base new file mode 100644 index 0000000..cec663b --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/7c/7c9811077d5ceb530eb843fd87b7a2fbf5f40409.svn-base @@ -0,0 +1,22 @@ +MODULE defprec +!- +! $Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!!-------------------------------------------------------------------- +!! The module "defprec" set default precision for computation +!! +!! This module should be used by every modules +!! to keep the right precision for every variable +!!-------------------------------------------------------------------- +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER,PARAMETER :: i_1=SELECTED_INT_KIND(2) + INTEGER,PARAMETER :: i_2=SELECTED_INT_KIND(4) + INTEGER,PARAMETER :: i_4=SELECTED_INT_KIND(9) + INTEGER,PARAMETER :: i_8=SELECTED_INT_KIND(13) + INTEGER,PARAMETER :: r_4=SELECTED_REAL_KIND(6,37) + INTEGER,PARAMETER :: r_8=SELECTED_REAL_KIND(15,307) + INTEGER,PARAMETER :: i_std=i_4, r_std=r_8 +!----------------- +END MODULE defprec diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/85/855b86b1df126ffcf3ef5407431d909118c8cfa9.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/85/855b86b1df126ffcf3ef5407431d909118c8cfa9.svn-base new file mode 100644 index 0000000..911abdf --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/85/855b86b1df126ffcf3ef5407431d909118c8cfa9.svn-base @@ -0,0 +1,82 @@ + +enum token { + tok_menuname, + tok_menuoption, + tok_comment, + tok_bool, + tok_tristate, + tok_dep_tristate, + tok_nop, + tok_if, + tok_else, + tok_fi, + tok_int, + tok_hex, + tok_make, + tok_define, + tok_choose, + tok_choice, + tok_endmenu, + tok_unknown +}; + +enum operator { + op_eq, + op_neq, + op_and, + op_and1, + op_or, + op_bang, + op_lparen, + op_rparen, + op_variable, + op_kvariable, + op_shellcmd, + op_constant, + op_nuked +}; + +union var +{ + char * str; + struct kconfig * cfg; +}; + +struct condition +{ + struct condition * next; + enum operator op; + union var variable; +}; + +#define GLOBAL_WRITTEN 1 +#define CFG_DUP 2 +#define UNSAFE 4 + +struct kconfig +{ + struct kconfig * next; + int flags; + enum token tok; + char menu_number; + char menu_line; + char submenu_start; + char submenu_end; + char * optionname; + char * label; + char * value; + int choice_value; + struct kconfig * choice_label; + union var depend; + struct condition * cond; +}; + +extern struct kconfig * config; +extern struct kconfig * clast; +extern struct kconfig * koption; + +/* + * Prototypes + */ +void fix_conditionals(struct kconfig * scfg); /* tkcond.c */ +void dump_tk_script(struct kconfig *scfg); /* tkgen.c */ diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/8a/8acc178a2aca18df1ec0172f06fb0d34e7a4d9ba.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/8a/8acc178a2aca18df1ec0172f06fb0d34e7a4d9ba.svn-base new file mode 100644 index 0000000..e1e054c --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/8a/8acc178a2aca18df1ec0172f06fb0d34e7a4d9ba.svn-base @@ -0,0 +1,2546 @@ +MODULE restcom +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!- +USE netcdf +!- +USE errioipsl, ONLY : ipslerr,ipsldbg +USE stringop +USE calendar +USE mathelp +USE fliocom, ONLY : flio_dom_file,flio_dom_att +!- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: & + & restini, restget, restput, restclo, & + & ioconf_setatt, ioget_vname, ioconf_expval, & + & ioget_expval, ioget_vdim +!- +INTERFACE restput + MODULE PROCEDURE & + & restput_r3d, restput_r2d, restput_r1d, & + & restput_opp_r2d, restput_opp_r1d +END INTERFACE +!- +INTERFACE restget + MODULE PROCEDURE & + & restget_r3d,restget_r2d,restget_r1d, & + & restget_opp_r2d,restget_opp_r1d +END INTERFACE +!- +! We do not use allocatable arrays because these sizes are safe +! and we do not know from start how many variables will be in +! the out file. +!- + INTEGER,PARAMETER :: & + & max_var=500, max_file=50, max_dim=NF90_MAX_VAR_DIMS +!- + CHARACTER(LEN=9),SAVE :: calend_str='unknown' +!- +! The IDs of the netCDF files are going in pairs. +! The input one (netcdf_id(?,1)) and the output one (netcdf_id(?,2)) +!- + INTEGER,SAVE :: nb_fi = 0 + INTEGER,DIMENSION(max_file,2),SAVE :: netcdf_id = -1 +!- +! Description of the content of the 'in' files and the 'out' files. +! Number of variables : nbvar_* +! Number of dimensions : nbdim_* +! ID of the time axis : tdimid_* +!- + INTEGER,SAVE :: nbvar_in(max_file), nbvar_out(max_file) + INTEGER,SAVE :: tdimid_in(max_file), tdimid_out(max_file) +!- +! Variables for one or the other file +!- +! Number of dimensions in the input file : nbdim_in +! Number of variables read so far from the input file : nbvar_read +! Type of variable read from the input file : vartyp_in +! (Could be used later to test if we have a restart file) +!- + INTEGER,SAVE :: nbdim_in(max_file), nbvar_read(max_file) + INTEGER,SAVE :: vartyp_in(max_file, max_var) +!- +! Time step and time origine in the input file. +!- + REAL,DIMENSION(max_file),SAVE :: deltat,timeorig +!- +! Description of the axes in the output file +!- +! tstp_out : Index on the tie axis currently beeing written +! itau_out : Time step which is written on this index of the file +!- + INTEGER,DIMENSION(max_file),SAVE :: tstp_out,itau_out +!- +! Description of the axes in the output file +!- +! For the ?ax_infs variable the following order is used : +! ?ax_infs (if,in,1) = size of axis +! ?ax_infs (if,in,2) = id of dimension +! Number of x,y and z axes in the output file : +! ?ax_nb(if) +!- + INTEGER,DIMENSION(max_file,max_dim,2),SAVE :: & + & xax_infs,yax_infs,zax_infs + INTEGER,DIMENSION(max_file),SAVE :: & + & xax_nb=0,yax_nb=0,zax_nb=0 +!- +! Description of the time axes in the input and output files +!- +! ID of the variable which contains the itaus : +! tind_varid_* +! ID of the variables which contains the seconds since date : +! tax_varid_* +! Size of the time axis in the input file : +! tax_size_in +!- + INTEGER,SAVE :: tind_varid_in(max_file), tax_varid_in(max_file), & + & tind_varid_out(max_file), tax_varid_out(max_file) + INTEGER,SAVE :: tax_size_in(max_file)=1 +!- +! The two time axes we have in the input file : +! t_index : dates in itaus +! (thus the variable has a tstep_sec attribute) +! t_julian : Julian days of the time axis +!- + INTEGER,SAVE,ALLOCATABLE :: t_index(:,:) + REAL,SAVE,ALLOCATABLE :: t_julian(:,:) +!- +! Here we save a number of informations on the variables +! in the files we are handling +!- +! Name of variables : varname_* +! ID of the variables : varid_* +! Number of dimensions of the variable : varnbdim_* +! Dimensions which are used for the variable : vardims_* +! Number of attributes for a variables : varatt_* +! A flag which markes the variables we have worked on : touched_* +!- + CHARACTER(LEN=20),DIMENSION(max_file,max_var),SAVE :: & + & varname_in,varname_out + INTEGER,DIMENSION(max_file,max_var),SAVE :: & + & varid_in,varid_out,varnbdim_in,varatt_in + INTEGER,DIMENSION(max_file,max_var,max_dim),SAVE :: & + & vardims_in + LOGICAL,DIMENSION(max_file,max_var),SAVE :: & + & touched_in,touched_out +!- + CHARACTER(LEN=120),SAVE :: indchfun= 'scatter, fill, gather, coll' + REAL,PARAMETER :: missing_val=1.e20 +! or HUGE(1.0) (maximum real number) +!- +! The default value we will use for variables +! which are not present in the restart file +!- + REAL,SAVE :: val_exp = 999999. + LOGICAL,SAVE :: lock_valexp = .FALSE. +!- +! Temporary variables in which we store the attributed which are going +! to be given to a new variable which is going to be defined. +!- + CHARACTER(LEN=80),SAVE :: rest_units='XXXXX',rest_lname='XXXXX' +!- +! For allocations +!- + REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp1,buff_tmp2 +!- +!=== +CONTAINS +!=== +!- +SUBROUTINE restini & + & (fnamein,iim,jjm,lon,lat,llm,lev, & + & fnameout,itau,date0,dt,fid,owrite_time_in,domain_id) +!--------------------------------------------------------------------- +!- This subroutine sets up all the restart process. +!- It will call the subroutine which opens the input +!- and output files. +!- The time step (itau), date of origine (date0) and time step are +!- READ from the input file. +!- A file ID, which is common to the input and output file is returned +!- +!- If fnamein = fnameout then the same file is used for the reading +!- the restart conditions and writing the new restart. +!- +!- A special mode can be switched in with filename='NONE'. +!- This means that no restart file is present. +!- Usefull for creating the first restart file +!- or to get elements in a file without creating an output file. +!- +!- A mode needs to be written in which itau, date0 and dt +!- are given to the restart process and thus +!- written into the output restart file. +!- +!- INPUT +!- +!- fnamein : name of the file for the restart +!- iim : Dimension in x +!- jjm : Dimension in y +!- lon : Longitude in the x,y domain +!- lat : Latitude in the x,y domain +!- llm : Dimension in the vertical +!- lev : Positions of the levels +!- fnameout : +!- +!- OUTPUT +!- +!- itau : Time step of the restart file and at which the model +!- should restart +!- date0 : Time at which itau = 0 +!- dt : time step in seconds between two succesiv itaus +!- fid : File identification of the restart file +!- +!- Optional INPUT arguments +!- +!- owrite_time_in : logical argument which allows to +!- overwrite the time in the restart file +!- domain_id : Domain identifier +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: fnamein,fnameout + INTEGER :: iim,jjm,llm,fid,itau + REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) + REAL :: date0,dt + LOGICAL,OPTIONAL :: owrite_time_in + INTEGER,INTENT(IN),OPTIONAL :: domain_id +!- + INTEGER :: ncfid + REAL :: dt_tmp,date0_tmp + LOGICAL :: l_fi,l_fo,l_rw + LOGICAL :: overwrite_time + CHARACTER(LEN=120) :: fname + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 Prepare the configuration before opening any files +!- + IF (.NOT.PRESENT(owrite_time_in)) THEN + overwrite_time = .FALSE. + ELSE + overwrite_time = owrite_time_in + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) 'restini 0.0 : ',TRIM(fnamein),' , ',TRIM(fnameout) + ENDIF +!- + nb_fi = nb_fi+1 +!- + IF (nb_fi > max_file) THEN + CALL ipslerr (3,'restini',& + & 'Too many restart files are used. The problem can be',& + & 'solved by increasing max_file in restcom.f90 ',& + & 'and recompiling ioipsl.') + ENDIF +!- +! 0.1 Define the open flags +!- + l_fi = (TRIM(fnamein) /= 'NONE') + l_fo = (TRIM(fnameout) /= 'NONE') + IF ((.NOT.l_fi).AND.(.NOT.l_fo)) THEN + CALL ipslerr (3,'restini',& + & 'Input and output file names are both to NONE.',& + & 'It is probably an error.','Verify your logic.') + ENDIF + l_rw = l_fi.AND.l_fo.AND.(TRIM(fnamein) == TRIM(fnameout)) +!- + IF (l_dbg) THEN + WRITE(*,*) 'restini 0.1 l_fi, l_fo, l_rw : ',l_fi,l_fo,l_rw + ENDIF +!- +! 1.0 Open the input file. +!- + IF (l_fi) THEN +!--- + IF (l_dbg) WRITE(*,*) 'restini 1.0 : Open input file' +!-- Add DOMAIN number and ".nc" suffix in file names if needed + fname = fnamein + CALL flio_dom_file (fname,domain_id) +!-- Open the file + CALL restopenin (nb_fi,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid) + netcdf_id(nb_fi,1) = ncfid +!--- +!-- 1.3 Extract the time information +!--- + IF (overwrite_time) THEN + date0_tmp = date0 + ENDIF + CALL restsett (dt_tmp,date0_tmp,itau,overwrite_time) + IF (.NOT.overwrite_time) THEN + dt = dt_tmp + date0 = date0_tmp + ENDIF +!--- + ELSE +!--- +!-- 2.0 The case of a missing restart file is dealt with +!--- + IF (l_dbg) WRITE(*,*) 'restini 2.0' +!--- + IF ( (ALL(MINLOC(lon(:iim,:jjm)) == MAXLOC(lon(:iim,:jjm)))) & + .AND.(iim > 1) ) THEN + CALL ipslerr (3,'restini',& + & 'For creating a restart file the longitudes of the',& + & 'grid need to be provided to restini. This ',& + & 'information is needed for the restart files') + ENDIF + IF ( (ALL(MINLOC(lat(:iim,:jjm)) == MAXLOC(lat(:iim,:jjm)))) & + .AND.(jjm > 1) ) THEN + CALL ipslerr (3,'restini',& + & 'For creating a restart file the latitudes of the',& + & 'grid need to be provided to restini. This ',& + & 'information is needed for the restart files') + ENDIF + IF ( (ALL(MINLOC(lev(:llm)) == MAXLOC(lev(:llm)))) & + .AND.(llm > 1) ) THEN + CALL ipslerr (3,'restini',& + & 'For creating a restart file the levels of the',& + & 'grid need to be provided to restini. This',& + & 'information is needed for the restart files') + ENDIF +!--- +!-- 2.2 Allocate the time axes and write the inputed variables +!--- + tax_size_in(nb_fi) = 1 + CALL rest_atim (l_dbg,'restini') + t_index(nb_fi,1) = itau + t_julian(nb_fi,1) = date0 + ENDIF +!- + IF (l_fo.AND.(.NOT.l_rw)) THEN +!-- Add DOMAIN number and ".nc" suffix in file names if needed + fname = fnameout + CALL flio_dom_file (fname,domain_id) +!-- Open the file + CALL restopenout & + (nb_fi,fname,iim,jjm,lon,lat,llm,lev,dt,date0,ncfid,domain_id) + netcdf_id(nb_fi,2) = ncfid + ELSE IF (l_fi.AND.l_fo) THEN + netcdf_id(nb_fi,2) = netcdf_id(nb_fi,1) + varname_out(nb_fi,:) = varname_in(nb_fi,:) + nbvar_out(nb_fi) = nbvar_in(nb_fi) + tind_varid_out(nb_fi) = tind_varid_in(nb_fi) + tax_varid_out(nb_fi) = tax_varid_in(nb_fi) + varid_out(nb_fi,:) = varid_in(nb_fi,:) + touched_out(nb_fi,:) = .TRUE. + ENDIF +!- +! 2.3 Set the calendar for the run. +! This should not produce any error message if +! This does not mean any change in calendar +! (to be modified in ioconf_calendar) +!- + IF (l_dbg) THEN + WRITE(*,*) 'restini 2.3 : Configure calendar if needed : ', & + calend_str + ENDIF +!- + IF (INDEX(calend_str,'unknown') < 1) THEN + CALL ioconf_calendar (calend_str) + IF (l_dbg) THEN + WRITE(*,*) 'restini 2.3b : new calendar : ',calend_str + ENDIF + ENDIF +!- +! Save some data in the module +!- + deltat(nb_fi) = dt +!- +! Prepare the variables which will be returned +!- + fid = nb_fi + IF (l_dbg) THEN + WRITE(*,*) 'SIZE of t_index :',SIZE(t_index), & + SIZE(t_index,dim=1),SIZE(t_index,dim=2) + WRITE(*,*) 't_index = ',t_index(fid,:) + ENDIF + itau = t_index(fid,1) +!- + IF (l_dbg) WRITE(*,*) 'restini END' +!--------------------- +END SUBROUTINE restini +!=== +SUBROUTINE restopenin & + (fid,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid) +!--------------------------------------------------------------------- +!- Opens the restart file and checks that it belongsd to the model. +!- This means that the coordinates of the model are compared to the +!- ones in the file. +!- +!- The number and name of variable in the file are exctracted. Also +!- the time details. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid,iim,jjm,llm + CHARACTER(LEN=*),INTENT(IN) :: fname + REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) + LOGICAL,INTENT(IN) :: l_rw + INTEGER,INTENT(OUT) :: ncfid +!- + INTEGER,DIMENSION(max_dim) :: var_dims,dimlen + INTEGER :: nb_dim,nb_var,id_unl,id,iv + INTEGER :: iread,jread,lread,iret + INTEGER :: lon_vid,lat_vid + REAL :: lon_read(iim,jjm),lat_read(iim,jjm) + REAL :: lev_read(llm) + REAL :: mdlon,mdlat + CHARACTER(LEN=80) :: units + CHARACTER(LEN=NF90_max_name),DIMENSION(max_dim) :: dimname + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! If we reuse the same file for input and output +! then we open it in write mode +!- + IF (l_rw) THEN; id = NF90_WRITE; ELSE; id = NF90_NOWRITE; ENDIF + iret = NF90_OPEN(fname,id,ncfid) + IF (iret /= NF90_NOERR) THEN + CALL ipslerr (3,'restopenin','Could not open file :',fname,' ') + ENDIF +!- + IF (l_dbg) WRITE (*,*) "restopenin 0.0 ",TRIM(fname) + iret = NF90_INQUIRE(ncfid,nDimensions=nb_dim, & + & nVariables=nb_var,unlimitedDimId=id_unl) + tdimid_in(fid) = id_unl +!- + IF (nb_dim > max_dim) THEN + CALL ipslerr (3,'restopenin',& + & 'More dimensions present in file that can be store',& + & 'Please increase max_dim in the global variables ',& + & 'in restcom.F90') + ENDIF + IF (nb_var > max_var) THEN + CALL ipslerr (3,'restopenin',& + & 'More variables present in file that can be store',& + & 'Please increase max_var in the global variables ',& + & 'in restcom.F90') + ENDIF +!- + nbvar_in(fid) = nb_var + nbdim_in(fid) = nb_dim + iread = -1; jread = -1; lread = -1; + DO id=1,nb_dim + iret = NF90_INQUIRE_DIMENSION(ncfid,id, & + & len=dimlen(id),name=dimname(id)) + IF (l_dbg) THEN + WRITE (*,*) "restopenin 0.0 dimname",id,TRIM(dimname(id)) + ENDIF + IF (TRIM(dimname(id)) == 'x') THEN + iread = dimlen(id) + IF (l_dbg) WRITE (*,*) "iread",iread + ELSE IF (TRIM(dimname(id)) == 'y') THEN + jread = dimlen(id) + IF (l_dbg) WRITE (*,*) "jread",jread + ELSE IF (TRIM(dimname(id)) == 'z') THEN + lread = dimlen(id) + IF (l_dbg) WRITE (*,*) "lread",lread + ENDIF + ENDDO +!- + IF (id_unl > 0) THEN +!--- +!-- 0.1 If we are going to add values to this file +!-- we need to know where it ends +!-- We also need to have all the dimensions in the file +!--- + IF (l_rw) THEN + tstp_out(fid) = dimlen(id_unl) + itau_out(fid) = -1 + tdimid_out(fid) = tdimid_in(fid) + IF (l_dbg) THEN + WRITE (*,*) & + & "restopenin 0.0 unlimited axis dimname", & + & dimname(id_unl),tstp_out(fid) + ENDIF +!----- + xax_nb(fid) = 0 + yax_nb(fid) = 0 + zax_nb(fid) = 0 +!----- + DO id=1,nb_dim + IF (dimname(id)(1:1) == 'x') THEN + xax_nb(fid) = xax_nb(fid)+1 + xax_infs(fid,xax_nb(fid),1) = dimlen(id) + xax_infs(fid,xax_nb(fid),2) = id + ELSE IF (dimname(id)(1:1) == 'y') THEN + yax_nb(fid) = yax_nb(fid)+1 + yax_infs(fid,yax_nb(fid),1) = dimlen(id) + yax_infs(fid,yax_nb(fid),2) = id + ELSE IF (dimname(id)(1:1) == 'z') THEN + zax_nb(fid) = zax_nb(fid)+1 + zax_infs(fid,zax_nb(fid),1) = dimlen(id) + zax_infs(fid,zax_nb(fid),2) = id + ENDIF + ENDDO + ENDIF + ELSE +!--- +!-- Still need to find a method for dealing with this +!--- +! CALL ipslerr (3,'restopenin',& +! & ' We do not deal yet with files without time axis.',' ',' ') + ENDIF +!- +! 1.0 First let us check that we have the righ restart file +!- + IF ((iread /= iim).OR.(jread /= jjm).OR.(lread /= llm)) THEN + CALL ipslerr (3,'restopenin',& + & 'The grid of the restart file does not correspond',& + & 'to that of the model',' ') + ENDIF +!- +! 2.0 Get the list of variables +!- + IF (l_dbg) WRITE(*,*) 'restopenin 1.2' +!- + lat_vid = -1 + lon_vid = -1 + tind_varid_in(fid) = -1 + tax_varid_in(fid) = -1 +!- + DO iv=1,nb_var +!--- + varid_in(fid,iv) = iv + var_dims(:) = 0 + iret = NF90_INQUIRE_VARIABLE(ncfid,iv, & + & name=varname_in(fid,iv),xtype=vartyp_in(fid,iv), & + & ndims=varnbdim_in(fid,iv),dimids=var_dims, & + & nAtts=varatt_in(fid,iv)) +!--- + DO id=1,varnbdim_in(fid,iv) + iret = NF90_INQUIRE_DIMENSION & + & (ncfid,var_dims(id),len=vardims_in(fid,iv,id)) + ENDDO +!--- +!-- 2.1 Read the units of the variable +!--- + units='' + iret = NF90_GET_ATT(ncfid,iv,'units',units) + CALL strlowercase (units) + CALL cmpblank (units) +!--- +!-- 2.2 Catch the time variables +!--- + IF (varnbdim_in(fid,iv) == 1) THEN + IF ( (INDEX(units,'timesteps since') > 0) & + .AND.(tind_varid_in(fid) < 0) ) THEN + tind_varid_in(fid) = iv + tax_size_in(fid) = vardims_in(fid,iv,1) + ENDIF + IF ( (INDEX(units,'seconds since') > 0) & + .AND.(tax_varid_in(fid) < 0) ) THEN + tax_varid_in(fid) = iv + tax_size_in(fid) = vardims_in(fid,iv,1) + ENDIF + ENDIF +!--- +!-- 2.3 Catch longitude and latitude variables +!--- + IF (INDEX(units,'degrees_nort') > 0) THEN + lat_vid = iv + ELSE IF (INDEX(units,'degrees_east') > 0) THEN + lon_vid = iv + ENDIF +!--- + ENDDO +!- +! 2.4 None of the variables was yet read +!- + nbvar_read(fid) = 0 + touched_in(fid,:) = .FALSE. +!- +! 3.0 Reading the coordinates from the input restart file +!- + lon_read = missing_val + lat_read = missing_val +!- + IF (lon_vid < 0 .OR. lat_vid < 0) THEN + CALL ipslerr (3,'restopenin',& + & ' No variables containing longitude or latitude were ',& + & ' found in the restart file.',' ') + ELSE + iret = NF90_GET_VAR(ncfid,lon_vid,lon_read) + iret = NF90_GET_VAR(ncfid,lat_vid,lat_read) +!--- + IF ( (ABS( MAXVAL(lon(:,:)) & + & -MINVAL(lon(:,:))) < EPSILON(MAXVAL(lon(:,:)))) & + & .AND.(ABS( MAXVAL(lat(:,:)) & + & -MINVAL(lat(:,:))) < EPSILON(MAXVAL(lat(:,:)))) ) THEN +!----- +!---- 3.1 No longitude nor latitude are provided thus +!---- they are taken from the restart file +!----- + lon(:,:) = lon_read(:,:) + lat(:,:) = lat_read(:,:) + ELSE +!----- +!---- 3.2 We check that the longitudes and latitudes +!---- in the file and the model are the same +!----- + mdlon = MAXVAL(ABS(lon_read-lon)) + mdlat = MAXVAL(ABS(lat_read-lat)) +!----- +!---- We can not test against epsilon here as the longitude +!---- can be stored at another precision in the netCDF file. +!---- The test here does not need to be very precise. +!----- + IF (mdlon > 1.e-4 .OR. mdlat > 1.e-4) THEN + CALL ipslerr (3,'restopenin',& + & ' The longitude or latitude found in the restart ',& + & ' file are not the same as the ones used in the model.',& + & ' ') + ENDIF + ENDIF + ENDIF +!------------------------ +END SUBROUTINE restopenin +!=== +SUBROUTINE restsett (timestep,date0,itau,owrite_time_in) +!--------------------------------------------------------------------- +!- Here we get all the time information from the file. +!- +!- The time information can come in three forms : +!- -global attributes which give the time origine and the +!- time step is taken from the input to restinit +!- -A physical time exists and thus the julian date from the +!- input is used for positioning using the itau as input +!- -A time-step axis exists and itau is positioned on it. +!- +!- What takes precedence : the model +!- +!- itau : Time step of the model +!- +!- Optional INPUT arguments +!- +!- owrite_time_in : logical argument which allows to +!- overwrite the time in the restart file +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL :: date0,timestep + INTEGER :: itau + LOGICAL,OPTIONAL :: owrite_time_in +!- + INTEGER :: ncfid,iret,it,iax,iv + CHARACTER(LEN=80) :: itau_orig,tax_orig,calendar + CHARACTER(LEN=9) :: tmp_cal + INTEGER :: year0,month0,day0,hours0,minutes0,seci + REAL :: sec0,one_day,one_year,date0_ju,ttmp + CHARACTER :: strc + LOGICAL :: ow_time + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (PRESENT(owrite_time_in)) THEN + ow_time = owrite_time_in + ELSE + ow_time = .FALSE. + ENDIF +!- + ncfid = netcdf_id(nb_fi,1) +!- +! Allocate the space we need for the time axes +!- + CALL rest_atim (l_dbg,'restsett') +!- +! Get the calendar if possible. Else it will be gregorian. +!- + IF (tax_size_in(nb_fi) > 0) THEN + calendar = ' ' + iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',calendar) + IF (iret == NF90_NOERR) THEN + CALL ioconf_calendar (calendar) + IF (l_dbg) THEN + WRITE(*,*) 'restsett : calendar of the restart ',calendar + ENDIF + ENDIF + ENDIF + CALL ioget_calendar (one_year,one_day) + IF (l_dbg) THEN + WRITE(*,*) 'one_year,one_day = ',one_year,one_day + ENDIF +!- + itau_orig = 'XXXXX' + tax_orig = 'XXXXX' +!- +! Get the time steps of the time axis if available on the restart file +!- + IF (tind_varid_in(nb_fi) > 0) THEN + IF (ow_time) THEN + t_index(nb_fi,:) = itau + IF (l_dbg) THEN + WRITE(*,*) "nb_fi,t_index",nb_fi,t_index(nb_fi,:) + ENDIF + CALL ju2ymds (date0,year0,month0,day0,sec0) + hours0 = NINT(sec0/3600) + sec0 = sec0 - 3600 * hours0 + minutes0 = NINT(sec0 / 60) + sec0 = sec0 - 60 * minutes0 + seci = NINT(sec0) + strc=':' + IF (l_dbg) THEN + WRITE(*,*) date0 + WRITE (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') & + & year0,'-',month0,'-',day0,' ',hours0,':',minutes0,':',seci + WRITE(*,*) "itau_orig : ",itau_orig + ENDIF + ELSE + iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:)) + IF (l_dbg) THEN + WRITE(*,*) "restsett, time axis : ",t_index(nb_fi,:) + ENDIF + iret = NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'units',itau_orig) + itau_orig = & + & itau_orig(INDEX(itau_orig,'since')+6:LEN_TRIM(itau_orig)) + iret = & + & NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'tstep_sec',timestep) +!----- +!---- This time origin will dominate as it is linked to the time steps. +!----- + READ (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') & + & year0,strc,month0,strc,day0,strc, & + & hours0,strc,minutes0,strc,seci + sec0 = REAL(seci) + sec0 = hours0*3600.+minutes0*60.+sec0 + CALL ymds2ju (year0,month0,day0,sec0,date0) + ENDIF + ENDIF +!- +! If a julian day time axis is available then we get it +!- + IF (tax_varid_in(nb_fi) > 0) THEN + iret = NF90_GET_VAR(ncfid,tax_varid_in(nb_fi),t_julian(nb_fi,:)) + iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'units',tax_orig) + tax_orig = tax_orig(INDEX(tax_orig,'since')+6:LEN_TRIM(tax_orig)) + tmp_cal = ' ' + iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',tmp_cal) + IF (l_dbg) THEN + WRITE(*,*) 'restsett : tmp_calendar of the restart ',tmp_cal + ENDIF +!--- + CALL strlowercase (tmp_cal) + IF (INDEX(calend_str,tmp_cal) < 1) THEN + IF (INDEX(calend_str,'unknown') > 0) THEN + calend_str = tmp_cal + ELSE + CALL ipslerr (2,'restsett', & + & ' In the restart files two different calendars were found.', & + & ' Please check the files you have used.',' ') + ENDIF + ENDIF +!--- +!-- We need to transform that into julian days +!-- to get ride of the intial date. +!--- + IF (l_dbg) WRITE(*,*) 'tax_orig : ',TRIM(tax_orig) + READ (UNIT=tax_orig,FMT='(I4.4,5(a,I2.2))') & + year0,strc,month0,strc,day0,strc, & + hours0,strc,minutes0,strc,seci + sec0 = REAL(seci) + sec0 = hours0*3600.+minutes0*60.+sec0 + CALL ymds2ju (year0,month0,day0,sec0,date0_ju) + t_julian(nb_fi,:) = t_julian(nb_fi,:)/one_day+date0_ju + ENDIF +!- + IF ( (INDEX(itau_orig,'XXXXX') > 0) & + .AND.(INDEX(tax_orig,'XXXXX') < 1) ) THEN +!!- Compute the t_itau from the date read and the timestep in the input + ENDIF +!- + IF ( (INDEX(tax_orig,'XXXXX') > 0) & + .AND.(INDEX(itau_orig,'XXXXX') < 1) ) THEN + DO it=1,tax_size_in(nb_fi) + t_julian(nb_fi,it) = itau2date(t_index(nb_fi,it),date0,timestep) + ENDDO + ENDIF +!- +! If neither the indices or time is present then get global attributes +! This is for compatibility reasons and should not be used. +!- + IF ((tax_varid_in(nb_fi) < 0).AND.(tind_varid_in(nb_fi) < 0)) THEN + iax = -1 + DO iv=1,nbvar_in(nb_fi) + IF ( (INDEX(varname_in(nb_fi,iv),'tsteps') > 0) & + & .OR.(INDEX(varname_in(nb_fi,iv),'time_steps') > 0)) THEN + iax = iv + ENDIF + ENDDO +!--- + IF (iax < 0) THEN + CALL ipslerr (3,'restsett',& + & 'No time axis was found in the restart file. Please check',& + & 'that it corresponds to the convention used in restsett',& + & ' ') + ELSE + iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:)) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'delta_tstep_sec',timestep) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'year0',ttmp) + year0 = NINT(ttmp) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'month0',ttmp) + month0 = NINT(ttmp) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'day0',ttmp) + day0 = NINT(ttmp) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'sec0',sec0) +!--- + CALL ymds2ju (year0,month0,day0,sec0,date0) + t_julian(nb_fi,1) = itau2date(t_index(nb_fi,1),date0,timestep) + ENDIF + ENDIF +!---------------------- +END SUBROUTINE restsett +!=== +SUBROUTINE restopenout & + (fid,fname,iim,jjm, & + lon,lat,llm,lev,timestep,date,ncfid,domain_id) +!--------------------------------------------------------------------- +!- Opens the restart file for output. +!- The longitude and time variables are written. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid,iim,jjm,llm + CHARACTER(LEN=*) :: fname + REAL :: date,timestep + REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) + INTEGER,INTENT(OUT) :: ncfid + INTEGER,INTENT(IN),OPTIONAL :: domain_id +!- + INTEGER :: iret + CHARACTER(LEN=70) :: str_t + INTEGER :: x_id,y_id,z_id,itauid + INTEGER :: nlonid,nlatid,nlevid,timeid + INTEGER :: year,month,day,hours,minutes + REAL :: sec + CHARACTER(LEN=3),DIMENSION(12) :: & + cal = (/'JAN','FEB','MAR','APR','MAY','JUN', & + 'JUL','AUG','SEP','OCT','NOV','DEC'/) + CHARACTER(LEN=30) :: timenow + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) WRITE(*,*) "restopenout 0.0 ",TRIM(fname) +!- +! If we use the same file for input and output +!- we will not even call restopenout +!- + iret = NF90_CREATE(fname,NF90_NOCLOBBER,ncfid) + IF (iret == -35) THEN + CALL ipslerr (3,'restopenout',& + & ' The restart file aready exists on the disc. IOIPSL ',& + & ' will not overwrite it. You should remove the old one or ',& + & ' generate the new one with another name') + ENDIF +!- + iret = NF90_DEF_DIM(ncfid,'x',iim,x_id) + xax_nb(fid) = xax_nb(fid)+1 + xax_infs(fid,xax_nb(fid),1) = iim + xax_infs(fid,xax_nb(fid),2) = x_id +!- + iret = NF90_DEF_DIM(ncfid,'y',jjm,y_id) + yax_nb(fid) = yax_nb(fid)+1 + yax_infs(fid,yax_nb(fid),1) = jjm + yax_infs(fid,yax_nb(fid),2) = y_id +!- + iret = NF90_DEF_DIM(ncfid,'z',llm,z_id) + zax_nb(fid) = zax_nb(fid)+1 + zax_infs(fid,zax_nb(fid),1) = llm + zax_infs(fid,zax_nb(fid),2) = z_id +!- + iret = NF90_DEF_DIM(ncfid,'time',NF90_UNLIMITED,tdimid_out(fid)) +!- +! 1.0 Longitude +!- + IF (l_dbg) WRITE(*,*) "restopenout 1.0" +!- + iret = NF90_DEF_VAR(ncfid,"nav_lon",NF90_FLOAT,(/x_id,y_id/),nlonid) + iret = NF90_PUT_ATT(ncfid,nlonid,'units',"degrees_east") + iret = NF90_PUT_ATT(ncfid,nlonid,'valid_min',REAL(-180.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlonid,'valid_max',REAL( 180.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlonid,'long_name',"Longitude") +!- +! 2.0 Latitude +!- + IF (l_dbg) WRITE(*,*) "restopenout 2.0" +!- + iret = NF90_DEF_VAR(ncfid,"nav_lat",NF90_FLOAT,(/x_id,y_id/),nlatid) + iret = NF90_PUT_ATT(ncfid,nlatid,'units',"degrees_north") + iret = NF90_PUT_ATT(ncfid,nlatid,'valid_min',REAL(-90.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlatid,'valid_max',REAL( 90.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlatid,'long_name',"Latitude") +!- +! 3.0 Levels +!- + IF (l_dbg) WRITE(*,*) "restopenout 3.0" +!- + iret = NF90_DEF_VAR(ncfid,"nav_lev",NF90_FLOAT,z_id,nlevid) + iret = NF90_PUT_ATT(ncfid,nlevid,'units',"model_levels") + iret = NF90_PUT_ATT(ncfid,nlevid,'valid_min', & + & REAL(MINVAL(lev),KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlevid,'valid_max', & + & REAL(MAXVAL(lev),KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlevid,'long_name',"Model levels") +!- +! 4.0 Time axis, this is the seconds since axis +!- + IF (l_dbg) WRITE(*,*) "restopenout 4.0" +!- + iret = NF90_DEF_VAR(ncfid,"time",NF90_FLOAT, & + tdimid_out(fid),timeid) + tax_varid_out(fid) = timeid +!- + timeorig(fid) = date + CALL ju2ymds (date,year,month,day,sec) + hours = INT(sec/(60.*60.)) + minutes = INT((sec-hours*60.*60.)/60.) + sec = sec-(hours*60.*60.+minutes*60.) + WRITE (UNIT=str_t, & + FMT='("seconds since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') & + & year,month,day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT(ncfid,timeid,'units',TRIM(str_t)) +!- + CALL ioget_calendar (str_t) + iret = NF90_PUT_ATT(ncfid,timeid,'calendar',TRIM(str_t)) + iret = NF90_PUT_ATT(ncfid,timeid,'title','Time') + iret = NF90_PUT_ATT(ncfid,timeid,'long_name','Time axis') +!- + WRITE(UNIT=str_t, & + FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') & + & year,cal(month),day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT(ncfid,timeid,'time_origin',TRIM(str_t)) +!- +! 5.0 Time axis, this is the time steps since axis +!- + IF (l_dbg) WRITE(*,*) "restopenout 5.0" +!- + iret = NF90_DEF_VAR(ncfid,"time_steps",NF90_INT, & + & tdimid_out(fid),itauid) + tind_varid_out(fid) = itauid +!- + CALL ju2ymds (date,year,month,day,sec) +!- + hours = INT(sec/(60.*60.)) + minutes = INT((sec-hours*60.*60.)/60.) + sec = sec-(hours*60.*60.+minutes*60.) +!- + WRITE (UNIT=str_t, & + FMT='("timesteps since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') & + & year,month,day,hours,minutes,INT(sec) +!- + iret = NF90_PUT_ATT(ncfid,itauid,'units',TRIM(str_t)) + iret = NF90_PUT_ATT(ncfid,itauid,'title','Time steps') + iret = NF90_PUT_ATT(ncfid,itauid,'tstep_sec',REAL(timestep,KIND=4)) + iret = NF90_PUT_ATT(ncfid,itauid,'long_name','Time step axis') +!- + WRITE(UNIT=str_t, & + FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') & + & year,cal(month),day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT(ncfid,itauid,'time_origin',TRIM(str_t)) +!- +! 5.2 Write global attributes +!- + iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'Conventions',"CF-1.1") + iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'file_name',TRIM(fname)) +!! TO BE DONE LATER +!! iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL, & +!! 'production',TRIM(model_name)) +!! lock_modname = .TRUE. + CALL ioget_timestamp (timenow) + iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) +!- +! Add DOMAIN attributes if needed +!- + CALL flio_dom_att (ncfid,domain_id) +!- +! 6.0 The coordinates are written to the file +!- + iret = NF90_ENDDEF(ncfid) +!- + iret = NF90_PUT_VAR(ncfid,nlonid,lon) + iret = NF90_PUT_VAR(ncfid,nlatid,lat) + iret = NF90_PUT_VAR(ncfid,nlevid,lev) +!- +! 7.0 Set a few variables related to the out file +!- + nbvar_out(fid) = 0 + itau_out(fid) = -1 + tstp_out(fid) = 0 + touched_out(fid,:) = .FALSE. +!- +! 7.1 The file is put back in define mode. +! This will last until itau_out >= 0 +!- + iret = NF90_REDEF(ncfid) +!- + IF (l_dbg) WRITE(*,*) "restopenout END" +!------------------------- +END SUBROUTINE restopenout +!=== +SUBROUTINE restget_opp_r1d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha, & + & var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!- +!- Should work as restput_opp_r1d but the other way around ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL def_beha + REAL :: var(:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: req_sz,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF (nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'resget_opp_r1d', & + 'Unable to performe an operation on this variable as it has',& + 'a second and third dimension',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r1d') + CALL rest_alloc (2,req_sz,l_dbg,'restget_opp_r1d') +!- +! 2.0 Here we get the variable from the restart file +!- + CALL restget_real & + (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + zax_infs(fid,1,1),itau,def_beha,buff_tmp2) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + CALL mathop (topp,req_sz,buff_tmp2,missing_val, & + & nbindex,ijndex,scal,siz1,buff_tmp1) + var(:) = buff_tmp1(1:siz1) + ELSE + CALL ipslerr (3,'resget_opp_r1d', & + 'The operation you wish to do on the variable for the ',& + 'restart file is not allowed.',topp) + ENDIF +!----------------------------- +END SUBROUTINE restget_opp_r1d +!=== +SUBROUTINE restget_opp_r2d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha, & + & var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!- +!- Should work as restput_opp_r2d but the other way around ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL def_beha + REAL :: var(:,:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: jj,req_sz,ist,var_sz,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF (nbindex == iim .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'resget_opp_r2d', & + 'Unable to performe an operation on this variable as it has', & + 'a second and third dimension',vname_q) + ENDIF +!- + IF (jjm < 1) THEN + CALL ipslerr (3,'resget_opp_r2d', & + 'Please specify a second dimension which is the', & + 'layer on which the operations are performed',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r2d') + CALL rest_alloc (2,req_sz*jjm,l_dbg,'restget_opp_r2d') +!- +! 2.0 Here we get the full variable from the restart file +!- + CALL restget_real & + & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + & jjm,itau,def_beha,buff_tmp2) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + var_sz = siz1 + DO jj = 1,jjm + ist = (jj-1)*req_sz+1 + CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), & + & missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1) + var(:,jj) = buff_tmp1(1:siz1) + ENDDO + ELSE + CALL ipslerr (3,'resget_opp_r2d', & + 'The operation you wish to do on the variable for the ',& + 'restart file is not allowed.',topp) + ENDIF +!----------------------------- +END SUBROUTINE restget_opp_r2d +!=== +SUBROUTINE restget_r1d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL :: def_beha + REAL :: var(:) +!- + INTEGER :: ji,jl,req_sz,var_sz,siz1 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + var_sz = siz1 + CALL rest_alloc (1,var_sz,l_dbg,'restget_r1d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable requested from file should be ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable can only hold ",I6)') var_sz + CALL ipslerr (3,'restget_r1d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str, & + & '("the size of variable requested from file is ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable can hold ",I6)') var_sz + CALL ipslerr (2,'restget_r1d', & + 'There could be a problem here :',str,str2) + ENDIF +!- + CALL restget_real & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO ji=1,siz1 + jl=jl+1 + var(ji) = buff_tmp1(jl) + ENDDO +!------------------------- +END SUBROUTINE restget_r1d +!=== +SUBROUTINE restget_r2d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL :: def_beha + REAL :: var(:,:) +!- + INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + var_sz = siz1*siz2 + CALL rest_alloc (1,var_sz,l_dbg,'restget_r2d') +!- +! 2.0 Here we check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file should be ",I6)') TRIM(vname_q),req_sz + WRITE(str2, & + & '("but the provided variable can only hold ",I6)') var_sz + CALL ipslerr (3,'restget_r2d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file is ",I6)') TRIM(vname_q),req_sz + WRITE(str2,'("but the provided variable can hold ",I6)') var_sz + CALL ipslerr (2,'restget_r2d', & + 'There could be a problem here :',str,str2) + ENDIF +!- + CALL restget_real & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + var(ji,jj) = buff_tmp1(jl) + ENDDO + ENDDO +!------------------------- +END SUBROUTINE restget_r2d +!=== +SUBROUTINE restget_r3d & + (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL def_beha + REAL :: var(:,:,:) +!- + INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + siz3 = SIZE(var,3) + var_sz = siz1*siz2*siz3 + CALL rest_alloc (1,var_sz,l_dbg,'restget_r3d') +!- +! 2.0 Here we check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file should be ",I6)') TRIM(vname_q),req_sz + WRITE(str2, & + & '("but the provided variable can only hold ",I6)') var_sz + CALL ipslerr (3,'restget_r3d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file is ",I6)') TRIM(vname_q),req_sz + WRITE(str2,'("but the provided variable can hold ",I6)') var_sz + CALL ipslerr (2,'restget_r3d', & + 'There could be a problem here :',str,str2) + ENDIF +!- + CALL restget_real & + (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jk=1,siz3 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + var(ji,jj,jk) = buff_tmp1(jl) + ENDDO + ENDDO + ENDDO +!------------------------- +END SUBROUTINE restget_r3d +!=== +SUBROUTINE restget_real & + (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine is for getting a variable from the restart file. +!- A number of verifications will be made : +!- - Is this the first time we read this variable ? +!- - Are the dimensions correct ? +!- - Is the correct time step present in the file +!- - is a default behaviour possible. If not the model is stoped. +!- Default procedure is to write the content of val_exp on all values. +!- +!- INPUT +!- +!- fid : Identification of the file +!- vname_q : Name of the variable to be read +!- iim, jjm ,llm : Dimensions of the variable that should be read +!- itau : Time step at whcih we are when we want +!- to read the variable +!- def_beha : If the model can restart without this variable +!- then some strange value is given. +!- +!- OUTPUT +!- +!- var : Variable in which the data is put +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL :: def_beha + REAL :: var(:) +!- + INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia + CHARACTER(LEN=70) str,str2 + CHARACTER(LEN=80) attname + INTEGER,DIMENSION(4) :: corner,edge +!--------------------------------------------------------------------- + ncfid = netcdf_id(fid,1) +!- + CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb) +!- +! 1.0 If the variable is not present then ERROR or filled up +! by default values if allowed +!- + IF (vnb < 0) THEN + IF (def_beha) THEN +!----- + lock_valexp = .TRUE. + var(:) = val_exp +!---- + str = 'Variable '//TRIM(vname_q) & + //' is not present in the restart file' + CALL ipslerr (1,'restget', & + & str,'but default values are used to fill in',' ') +!---- + IF (nbvar_in(fid) >= max_var) THEN + CALL ipslerr (3,'restget', & + 'Too many variables for the restcom module', & + 'Please increase the value of max_var',' ') + ENDIF + nbvar_in(fid) = nbvar_in(fid)+1 + vnb = nbvar_in(fid) + varname_in(fid,vnb) = vname_q + touched_in(fid,vnb) = .TRUE. +!----- + CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.) +!----- + ELSE + str = 'Variable '//TRIM(vname_q) & + //' is not present in the restart file' + CALL ipslerr (3,'restget', & + & str,'but it is need to restart the model',' ') + ENDIF +!--- + ELSE +!--- +!-- 2.0 Check if the variable has not yet been read +!-- and that the time is OK +!--- + vid = varid_in(fid,vnb) +!--- + nbvar_read(fid) = nbvar_read(fid)+1 +!--- + IF (touched_in(fid,vnb)) THEN + str = 'Variable '//TRIM(vname_q) & + //' has already been read from file' + CALL ipslerr (3,'restget',str,' ',' ') + ENDIF +!--- +!-- 3.0 get the time step of the restart file +!-- and check if it is correct +!--- + index = -1 + DO it=1,tax_size_in(fid) + IF (t_index(fid,it) == itau) index = it + ENDDO + IF (index < 0) THEN + str = 'The time step requested for variable '//TRIM(vname_q) + CALL ipslerr (3,'restget', & + & str,'is not available in the current file',' ') + ENDIF +!--- +!-- 4.0 Read the data. Note that the variables in the restart files +!-- have no time axis is and thus we write -1 +!--- + str='Incorrect dimension for '//TRIM(vname_q) + ndim = 0 + IF (iim > 0) THEN + ndim = ndim+1 + IF (vardims_in(fid,vnb,ndim) == iim) THEN + corner(ndim) = 1 + edge(ndim) = iim + ELSE + WRITE (str2,'("Incompatibility for iim : ",I6,I6)') & + iim,vardims_in(fid,vnb,ndim) + CALL ipslerr (3,'restget',str,str2,' ') + ENDIF + ENDIF +!--- + IF (jjm > 0) THEN + ndim = ndim+1 + IF (vardims_in(fid,vnb,ndim) == jjm) THEN + corner(ndim) = 1 + edge(ndim) = jjm + ELSE + WRITE (str2,'("Incompatibility for jjm : ",I6,I6)') & + jjm,vardims_in(fid,vnb,ndim) + CALL ipslerr (3,'restget',str,str2,' ') + ENDIF + ENDIF +!--- + IF (llm > 0) THEN + ndim = ndim+1 + IF (vardims_in(fid,vnb,ndim) == llm) THEN + corner(ndim) = 1 + edge(ndim) = llm + ELSE + WRITE (str2,'("Incompatibility for llm : ",I6,I6)') & + llm,vardims_in(fid,vnb,ndim) + CALL ipslerr (3,'restget',str,str2,' ') + ENDIF + ENDIF +!--- +!-- Time +!--- + ndim = ndim+1 + corner(ndim) = index +!!????? edge(ndim) = index + edge(ndim) = 1 +!--- + iret = NF90_GET_VAR(ncfid,vid,var, & + & start=corner(1:ndim),count=edge(1:ndim)) +!--- +!-- 5.0 The variable we have just read is created +!-- in the next restart file +!--- + IF ( (netcdf_id(fid,1) /= netcdf_id(fid,2)) & + & .AND.(netcdf_id(fid,2) > 0) ) THEN +!----- + CALL restdefv (fid,vname_q,iim,jjm,llm,.FALSE.) +!----- + DO ia = 1,varatt_in(fid,vnb) + iret = NF90_INQ_ATTNAME(ncfid,vid,ia,attname) + iret = NF90_COPY_ATT(ncfid,vid,attname, & + & netcdf_id(fid,2),varid_out(fid,nbvar_out(fid))) + ENDDO +!----- + IF (itau_out(fid) >= 0) THEN + iret = NF90_ENDDEF(netcdf_id(fid,2)) + ENDIF + ENDIF +!--- + ENDIF +!-------------------------- +END SUBROUTINE restget_real +!=== +SUBROUTINE restput_opp_r1d & + & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine is the interface to restput_real which allows +!- to re-index data onto the original grid of the restart file. +!- The logic we use is still fuzzy in my mind but that is probably +!- only because I have not yet though through everything. +!- +!- In the case iim = nbindex it means that the user attempts +!- to project a vector back onto the original 2D or 3D field. +!- This requires that jjm and llm be equal to 1 or 0, +!- else I would not know what it means. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: req_sz,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF ( nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'restput_opp_r1d', & + 'Unable to performe an operation on this variable as it has', & + 'a second and third dimension',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r1d') + CALL rest_alloc (2,req_sz,l_dbg,'restput_opp_r1d') +!- +! 2.0 We do the operation needed. +! It can only be a re-indexing operation. +! You would not want to change the values in a restart file or ? +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + buff_tmp1(1:siz1) = var(:) + CALL mathop & + & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & + & scal,req_sz,buff_tmp2) + ELSE + CALL ipslerr (3,'restput_opp_r1d', & + & 'The operation you wish to do on the variable for the ', & + & 'restart file is not allowed.',topp) + ENDIF +!- + CALL restput_real & + & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + & zax_infs(fid,1,1),itau,buff_tmp2) +!----------------------------- +END SUBROUTINE restput_opp_r1d +!=== +SUBROUTINE restput_opp_r2d & + & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine is the interface to restput_real which allows +!- to re-index data onto the original grid of the restart file. +!- The logic we use is still fuzzy in my mind but that is probably +!- only because I have not yet though through everything. +!- +!- In the case iim = nbindex it means that the user attempts +!- to project the first dimension of the matrix back onto a 3D field +!- where jjm will be the third dimension. +!- Here we do not allow for 4D data, thus we will take the first +!- two dimensions in the file and require that llm = 1. +!- These are pretty heavy constraints but I do not know how +!- to make it more general. I need to think about it some more. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:,:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: jj,req_sz,ist,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF ( nbindex == iim .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'restput_opp_r2d', & + 'Unable to performe an operation on this variable as it has', & + 'a second and third dimension',vname_q) + ENDIF +!- + IF (jjm < 1) THEN + CALL ipslerr (3,'restput_opp_r2d', & + 'Please specify a second dimension which is the', & + 'layer on which the operations are performed',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r2d') + CALL rest_alloc (2,req_sz*jjm,l_dbg,'restput_opp_r2d') +!- +! 2.0 We do the operation needed. +! It can only be a re-indexing operation. +! You would not want to change the values in a restart file or ? +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + DO jj = 1,jjm + buff_tmp1(1:siz1) = var(:,jj) + ist = (jj-1)*req_sz+1 + CALL mathop & + & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & + & scal,req_sz,buff_tmp2(ist:ist+req_sz-1)) + ENDDO + ELSE + CALL ipslerr (3,'restput_opp_r2d', & + & 'The operation you wish to do on the variable for the ', & + & 'restart file is not allowed.',topp) + ENDIF +!- + CALL restput_real & + & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + & jjm,itau,buff_tmp2) +!----------------------------- +END SUBROUTINE restput_opp_r2d +!=== +SUBROUTINE restput_r1d (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restput_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:) +!- + INTEGER :: ji,jl,req_sz,var_sz,siz1 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + var_sz = siz1 + CALL rest_alloc (1,var_sz,l_dbg,'restput_r1d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable put to the file should be ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable is of size ",I6)') var_sz + CALL ipslerr (3,'restput_r1d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str,'("the size of variable put to the file is ",I6)') req_sz + WRITE(str2,'("but the provided variable is larger ",I6)') var_sz + CALL ipslerr (2,'restput_r1d', & + 'There could be a problem here :',str,str2) + ENDIF +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO ji=1,siz1 + jl=jl+1 + buff_tmp1(jl) = var(ji) + ENDDO +!- + CALL restput_real (fid,vname_q,iim,jjm,llm,itau,buff_tmp1) +!------------------------- +END SUBROUTINE restput_r1d +!=== +SUBROUTINE restput_r2d (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restput_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:,:) +!- + INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + var_sz = siz1*siz2 + CALL rest_alloc (1,var_sz,l_dbg,'restput_r2d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & +& '("Size of variable put to the file should be ",I6)') req_sz + WRITE(str2,'("but the provided variable is of size ",I6)') var_sz + CALL ipslerr (3,'restput_r2d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str,'("the size of variable put to the file is ",I6)') req_sz + WRITE(str2,'("but the provided variable is larger ",I6)') var_sz + CALL ipslerr (2,'restput_r2d', & + 'There could be a problem here :',str,str2) + ENDIF +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + buff_tmp1(jl) = var(ji,jj) + ENDDO + ENDDO +!- + CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1) +!------------------------- +END SUBROUTINE restput_r2d +!=== +SUBROUTINE restput_r3d (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restput_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:,:,:) +!- + INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + siz3 = SIZE(var,3) + var_sz = siz1*siz2*siz3 + CALL rest_alloc (1,var_sz,l_dbg,'restput_r3d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable put to the file should be ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable is of size ",I6)') var_sz + CALL ipslerr (3,'restput_r3d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str,'("the size of variable put to the file is ",I6)') req_sz + WRITE(str2,'("but the provided variable is larger ",I6)') var_sz + CALL ipslerr (2,'restput_r3d', & + 'There could be a problem here :',str,str2) + ENDIF +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jk=1,siz3 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + buff_tmp1(jl) = var(ji,jj,jk) + ENDDO + ENDDO + ENDDO +!- + CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1) +!------------------------- +END SUBROUTINE restput_r3d +!=== +SUBROUTINE restput_real (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine will put a variable into the restart file. +!- But it will do a lot of other things if needed : +!- - Open a file if non is opened for this time-step +!- and all variables were written. +!- - Add an axis if needed +!- - verify that the variable has the right time step for this file +!- - If it is time for a new file then it is opened +!- and the old one closed +!- This requires that variables read from the last restart file were all +!- written +!- +!- INPUT +!- +!- fid : Id of the file in which we will write the variable +!- vname_q : Name of the variable to be written +!- iim,jjm,llm : Size in 3D of the variable +!- itau : Time step at which the variable is written +!- var : Variable +!- +!- OUTPUT +!- +!- NONE +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: vname_q + INTEGER :: fid,iim,jjm,llm,itau + REAL :: var(:) +!- + INTEGER :: iret,vid,ncid,iv,vnb + INTEGER :: ierr + REAL :: secsince,one_day,one_year + INTEGER :: ndims + INTEGER,DIMENSION(4) :: corner,edge + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 Get some variables +!- + ncid = netcdf_id(fid,2) + IF (netcdf_id(fid,2) < 0) THEN + CALL ipslerr (3,'restput', & + & 'The output restart file is undefined.',' ',' ') + ENDIF + CALL ioget_calendar (one_year,one_day) +!- +! 1.0 Check if the variable is already present +!- + IF (l_dbg) WRITE(*,*) 'RESTPUT 1.0 : ',TRIM(vname_q) +!- + CALL find_str (varname_out(fid,1:nbvar_out(fid)),vname_q,vnb) +!- + IF (l_dbg) THEN + WRITE(*,*) 'RESTPUT 1.1 : ',varname_out(fid,1:nbvar_out(fid)),vnb + ENDIF +!- +! 2.0 If variable is not present then declare it +! and add extra dimensions if needed. +!- + IF (vnb <= 0) THEN + CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.) + vnb = nbvar_out(fid) + ENDIF + vid = varid_out(fid,vnb) +!- + IF (l_dbg) WRITE(*,*) 'RESTPUT 2.0 : ',vnb,vid +!- +! 2.1 Is this file already in write mode ? +! If itau_out is still negative then we have +! never written to it and we need to go into write mode. +!- + IF (itau_out(fid) < 0) THEN + iret = NF90_ENDDEF(ncid) + ENDIF +!- +! 3.0 Is this itau already on the axis ? +! If not then check that all variables of previous time is OK. +!- + IF (l_dbg) WRITE(*,*) 'RESTPUT 3.0 : ',itau,itau_out(fid) +!- + IF (itau /= itau_out(fid)) THEN +!--- +!-- If it is the first time step written on the restart +!-- then we only check the number +!-- Else we see if every variable was written +!--- + IF (tstp_out(fid) == 0) THEN + IF (nbvar_out(fid) < nbvar_read(fid)) THEN + WRITE(*,*) "ERROR :",tstp_out(fid), & + nbvar_out(fid),nbvar_read(fid) + CALL ipslerr (1,'restput', & + & 'There are fewer variables read from the output file', & + & 'than written onto the input file.', & + & 'We trust you know what you are doing') + ENDIF + ELSE + ierr = 0 + DO iv=1,nbvar_out(fid) + IF (.NOT.touched_out(fid,iv)) ierr = ierr+1 + ENDDO + IF (ierr > 0) THEN + WRITE(*,*) "ERROR :",nbvar_out(fid) + CALL ipslerr (1,'restput', & + & 'There are fewer variables in the output file for this', & + & 'time step than for the previous one',' ') + ELSE + touched_out(fid,:) = .FALSE. + ENDIF + ENDIF +!--- + secsince = itau*deltat(fid) + corner(1) = tstp_out(fid)+1 + edge(1) = 1 +!--- +!-- 3.1 Here we add the values to the time axes +!--- + IF (l_dbg) THEN + WRITE(*,*) 'RESTPUT 3.1 : ',itau,secsince,corner(1),edge(1) + ENDIF +!--- + iret = NF90_PUT_VAR(ncid,tind_varid_out(fid),itau, & + & start=corner(1:1)) + iret = NF90_PUT_VAR(ncid,tax_varid_out(fid),secsince, & + & start=corner(1:1)) +!--- + tstp_out(fid) = tstp_out(fid)+1 + itau_out(fid) = itau + ENDIF +!- +! 4.0 Variable and time step should be present +! now so we can dump variable +!- + ndims = 0 + IF (iim > 0) THEN + ndims = ndims+1 + corner(ndims) = 1 + edge(ndims) = iim + ENDIF + IF (jjm > 0) THEN + ndims = ndims+1 + corner(ndims) = 1 + edge(ndims) = jjm + ENDIF + IF (llm > 0) THEN + ndims = ndims+1 + corner(ndims) = 1 + edge(ndims) = llm + ENDIF + ndims = ndims+1 + corner(ndims) = tstp_out(fid) + edge(ndims) = 1 +!- + iret = NF90_PUT_VAR(ncid,vid,var, & + & start=corner(1:ndims),count=edge(1:ndims)) +!- + IF (iret /= NF90_NOERR) THEN + CALL ipslerr (2,'restput_real',NF90_STRERROR(iret), & + & 'Bug in restput.',& + & 'Please, verify compatibility between get and put commands.') + ENDIF +!- +! 5.0 Note that the variables was treated +!- + touched_out(fid,vnb) = .TRUE. +!--------------------------- +END SUBROUTINE restput_real +!=== +SUBROUTINE restdefv (fid,varname,iim,jjm,llm,write_att) +!--------------------------------------------------------------------- +! This subroutine adds a variable to the output file. +! The attributes are either taken from. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER ::fid + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm + LOGICAL :: write_att +!- + INTEGER :: dims(4),ic,xloc,ndim,ncfid + INTEGER :: iret,ax_id + CHARACTER(LEN=3) :: str + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + ncfid = netcdf_id(fid,2) + IF (nbvar_out(fid) >= max_var) THEN + CALL ipslerr (3,'restdefv', & + 'Too many variables for the restcom module', & + 'Please increase the value of max_var',' ') + ENDIF + nbvar_out(fid) = nbvar_out(fid)+1 + varname_out(fid,nbvar_out(fid)) = varname +!- +! 0.0 Put the file in define mode if needed +!- + IF (itau_out(fid) >= 0) THEN + iret = NF90_REDEF(ncfid) + ENDIF +!- +! 1.0 Do we have all dimensions and can we go ahead +!- + IF (l_dbg) THEN + WRITE(*,*) 'restdefv 1.0 :',TRIM(varname),nbvar_out(fid) + ENDIF +!- + ndim = 0 +!- +! 1.1 Work on x +!- + IF (iim > 0) THEN + ndim = ndim+1 + xloc = 0 + DO ic=1,xax_nb(fid) + IF (xax_infs(fid,ic,1) == iim) xloc = ic + ENDDO +!--- + IF (xloc > 0) THEN + dims(ndim) = xax_infs(fid,xloc,2) + ELSE + str='x_'//CHAR(96+xax_nb(fid)) + iret = NF90_DEF_DIM(ncfid,str,iim,ax_id) + xax_nb(fid) = xax_nb(fid)+1 + xax_infs(fid,xax_nb(fid),1) = iim + xax_infs(fid,xax_nb(fid),2) = ax_id + dims(ndim) = ax_id + ENDIF + ENDIF +!- +! 1.2 Work on y +!- + IF (jjm > 0) THEN + ndim = ndim+1 + xloc = 0 + DO ic=1,yax_nb(fid) + IF (yax_infs(fid,ic,1) == jjm) xloc = ic + ENDDO +!--- + IF (xloc > 0) THEN + dims(ndim) = yax_infs(fid,xloc,2) + ELSE + str='y_'//CHAR(96+yax_nb(fid)) + iret = NF90_DEF_DIM(ncfid,str,jjm,ax_id) + yax_nb(fid) = yax_nb(fid)+1 + yax_infs(fid,yax_nb(fid),1) = jjm + yax_infs(fid,yax_nb(fid),2) = ax_id + dims(ndim) = ax_id + ENDIF + ENDIF +!- +! 1.3 Work on z +!- + IF (llm > 0) THEN + ndim = ndim+1 + xloc = 0 + DO ic=1,zax_nb(fid) + IF (zax_infs(fid,ic,1) == llm) xloc = ic + ENDDO +!--- + IF (xloc > 0) THEN + dims(ndim) = zax_infs(fid,xloc,2) + ELSE + str='z_'//CHAR(96+zax_nb(fid)) + iret = NF90_DEF_DIM(ncfid,str,llm,ax_id) + zax_nb(fid) = zax_nb(fid)+1 + zax_infs(fid,zax_nb(fid),1) = llm + zax_infs(fid,zax_nb(fid),2) = ax_id + dims(ndim) = ax_id + ENDIF + ENDIF +!- +! 1.4 Time needs to be added +!- + ndim = ndim+1 + dims(ndim) = tdimid_out(fid) +!- +! 2.0 Declare the variable +!- + IF (l_dbg) THEN + WRITE(*,*) 'restdefv 2.0 :',ndim,' :: ',dims(1:ndim),tdimid_out(fid) + ENDIF +!- + iret = NF90_DEF_VAR(ncfid,varname,NF90_DOUBLE,dims(1:ndim), & + & varid_out(fid,nbvar_out(fid))) + IF (iret /= NF90_NOERR) THEN + CALL ipslerr (3,'restdefv', & + 'Could not define new variable in file', & + NF90_STRERROR(iret),varname) + ENDIF +!- +! 3.0 Add the attributes if requested +!- + IF (write_att) THEN + IF (rest_units /= 'XXXXX') THEN + iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & + & 'units',TRIM(rest_units)) + rest_units = 'XXXXX' + ENDIF +!--- + IF (rest_lname /= 'XXXXX') THEN + iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & + & 'long_name',TRIM(rest_lname)) + rest_lname = 'XXXXX' + ENDIF +!--- + iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & + & 'missing_value',REAL(missing_val,KIND=4)) +!--- + IF (itau_out(fid) >= 0) THEN + iret = NF90_ENDDEF(ncfid) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) & + & 'restdefv 3.0 : LIST OF VARS ',varname_out(fid,1:nbvar_out(fid)) + ENDIF +!---------------------- +END SUBROUTINE restdefv +!=== +SUBROUTINE rest_atim (l_msg,c_p) +!--------------------------------------------------------------------- +! Called by "c_p", [re]allocate the time axes +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,INTENT(IN) :: l_msg + CHARACTER(LEN=*),INTENT(IN) :: c_p +!- + INTEGER :: i_err,tszij + INTEGER,ALLOCATABLE :: tmp_index(:,:) + REAL,ALLOCATABLE :: tmp_julian(:,:) +!--------------------------------------------------------------------- +!- +! Allocate the space we need for the time axes +!- + IF (.NOT.ALLOCATED(t_index) .AND. .NOT.ALLOCATED(t_julian)) THEN + IF (l_msg) THEN + WRITE(*,*) TRIM(c_p)//' : Allocate times axes at :', & + & max_file,tax_size_in(nb_fi) + ENDIF +!--- + ALLOCATE(t_index(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_index : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of t_index','', & + & '(you must increase memory)') + ENDIF + t_index (:,:) = 0 +!--- + ALLOCATE(t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_julian : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of max_file,tax_size_in','', & + & '(you must increase memory)') + ENDIF + t_julian (:,:) = 0.0 + ELSE IF ( (SIZE(t_index,DIM=2) < tax_size_in(nb_fi)) & + & .OR.(SIZE(t_julian,DIM=2) < tax_size_in(nb_fi)) ) THEN + IF (l_msg) THEN + WRITE(*,*) TRIM(c_p)//' : Reallocate times axes at :', & + & max_file,tax_size_in(nb_fi) + ENDIF +!--- + ALLOCATE (tmp_index(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of tmp_index : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of tmp_index','', & + & '(you must increase memory)') + ENDIF + tszij = SIZE(t_index,DIM=2) + tmp_index(:,1:tszij) = t_index(:,1:tszij) + DEALLOCATE(t_index) + ALLOCATE (t_index(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_index : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in reallocation of t_index','', & + & '(you must increase memory)') + ENDIF + t_index(:,1:tszij) = tmp_index(:,1:tszij) +!--- + ALLOCATE (tmp_julian(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of tmp_julian : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of tmp_julian','', & + & '(you must increase memory)') + ENDIF + tszij = SIZE(t_julian,DIM=2) + tmp_julian(:,1:tszij) = t_julian(:,1:tszij) + DEALLOCATE(t_julian) + ALLOCATE (t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_julian : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in reallocation of t_julian','', & + & '(you must increase memory)') + ENDIF + t_julian(:,1:tszij) = tmp_julian(:,1:tszij) + ENDIF +!----------------------- +END SUBROUTINE rest_atim +!=== +SUBROUTINE rest_alloc (i_buff,i_qsz,l_msg,c_p) +!--------------------------------------------------------------------- +! Called by "c_p", allocate a temporary buffer +! (buff_tmp[1/2] depending on "i_buff" value) to the size "i_qsz". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: i_buff,i_qsz + LOGICAL,INTENT(IN) :: l_msg + CHARACTER(LEN=*),INTENT(IN) :: c_p +!- + INTEGER :: i_bsz,i_err + LOGICAL :: l_alloc1,l_alloc2 + CHARACTER(LEN=9) :: cbn + CHARACTER(LEN=5) :: c_err +!--------------------------------------------------------------------- + IF (i_buff == 1) THEN + IF (ALLOCATED(buff_tmp1)) THEN + i_bsz = SIZE(buff_tmp1) + ELSE + i_bsz = 0 + ENDIF + l_alloc1 = (.NOT.ALLOCATED(buff_tmp1)) & + & .OR.((ALLOCATED(buff_tmp1)).AND.(i_qsz > i_bsz)) + l_alloc2 = .FALSE. + cbn = 'buff_tmp1' + ELSE IF (i_buff == 2) THEN + IF (ALLOCATED(buff_tmp2)) THEN + i_bsz = SIZE(buff_tmp2) + ELSE + i_bsz = 0 + ENDIF + l_alloc1 = .FALSE. + l_alloc2 = (.NOT.ALLOCATED(buff_tmp2)) & + & .OR.((ALLOCATED(buff_tmp2)).AND.(i_qsz > i_bsz)) + cbn = 'buff_tmp2' + ELSE + CALL ipslerr (3,'rest_alloc', & + & 'Called by '//TRIM(c_p),'with a wrong value of i_buff','') + ENDIF +!- +!- + IF (l_alloc1.OR.l_alloc2) THEN + IF (l_msg) THEN + IF ( (l_alloc1.AND.ALLOCATED(buff_tmp1)) & + & .OR.(l_alloc2.AND.ALLOCATED(buff_tmp2)) ) THEN + WRITE(*,*) TRIM(c_p)//" : re_allocate "//TRIM(cbn)//"=",i_qsz + ELSE + WRITE(*,*) TRIM(c_p)//" : allocate "//TRIM(cbn)//"=",i_qsz + ENDIF + ENDIF + IF (l_alloc1) THEN + IF (ALLOCATED(buff_tmp1)) THEN + DEALLOCATE(buff_tmp1) + ENDIF + ALLOCATE (buff_tmp1(i_qsz),STAT=i_err) + ELSE + IF (ALLOCATED(buff_tmp2)) THEN + DEALLOCATE(buff_tmp2) + ENDIF + ALLOCATE (buff_tmp2(i_qsz),STAT=i_err) + ENDIF + IF (i_err /= 0) THEN + WRITE (UNIT=c_err,FMT='(I5)') i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of',TRIM(cbn), & + & 'Error : '//TRIM(c_err)//' (you must increase memory)') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE rest_alloc +!=== +SUBROUTINE ioconf_setatt (attname,value) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: attname,value +!- + CHARACTER(LEN=LEN_TRIM(attname)) :: tmp_str +!--------------------------------------------------------------------- + tmp_str = attname + CALL strlowercase (tmp_str) +!- + SELECT CASE(tmp_str) + CASE('units') + rest_units = value + CASE('long_name') + rest_lname = value + CASE DEFAULT + CALL ipslerr (2,'ioconf_restatt', & + 'The attribute name provided is unknown',attname,' ') + END SELECT +!--------------------------- +END SUBROUTINE ioconf_setatt +!=== +SUBROUTINE ioget_vdim (fid,vname_q,varnbdim_max,varnbdim,vardims) +!--------------------------------------------------------------------- +!- This routine allows the user to get the dimensions +!- of a field in the restart file. +!- This is the file which is read. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER,INTENT(IN) :: varnbdim_max + INTEGER,INTENT(OUT) :: varnbdim + INTEGER,DIMENSION(varnbdim_max),INTENT(OUT) :: vardims +!- + INTEGER :: vnb +!--------------------------------------------------------------------- +! Find the index of the variable + CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb) +!- + IF (vnb > 0) THEN + varnbdim = varnbdim_in(fid,vnb) + IF (varnbdim_max < varnbdim) THEN + CALL ipslerr (3,'ioget_vdim', & + 'The provided array for the variable dimensions is too small', & + '','') + ELSE + vardims(1:varnbdim) = vardims_in(fid,vnb,1:varnbdim) + ENDIF + ELSE + varnbdim = 0 + CALL ipslerr (2,'ioget_vdim', & + 'Variable '//TRIM(vname_q)//' not found','','') + ENDIF +!------------------------ +END SUBROUTINE ioget_vdim +!=== +SUBROUTINE ioget_vname (fid,nbvar,varnames) +!--------------------------------------------------------------------- +!- This routine allows the user to extract the list +!- of variables in an opened restart file. +!- This is the file which is read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid + INTEGER,INTENT(OUT) :: nbvar + CHARACTER(LEN=*),INTENT(OUT) :: varnames(:) +!--------------------------------------------------------------------- + nbvar = nbvar_in(fid) +!- + IF (SIZE(varnames) < nbvar) THEN + CALL ipslerr (3,'ioget_vname', & + 'The provided array for the variable names is too small','','') + ELSE + varnames(1:nbvar) = varname_in(fid,1:nbvar) + ENDIF +!------------------------- +END SUBROUTINE ioget_vname +!=== +SUBROUTINE ioconf_expval (new_exp_val) +!--------------------------------------------------------------------- +!- The default value written into the variables which are not +!- in the restart file can only be changed once. +!- This avoids further complications. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL :: new_exp_val +!--------------------------------------------------------------------- + IF (.NOT.lock_valexp) THEN + lock_valexp = .TRUE. + val_exp = new_exp_val + ELSE + CALL ipslerr (2,'ioconf_expval', & + 'The default value for variable' & + //'not available in the restart file ', & + 'has already been locked and can not be changed at this point', & + ' ') + ENDIF +!--------------------------- +END SUBROUTINE ioconf_expval +!=== +SUBROUTINE ioget_expval (get_exp_val) +!--------------------------------------------------------------------- +!- Once the user has extracted the default value, +!- we lock it so that it can not be changed anymore. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL :: get_exp_val +!--------------------------------------------------------------------- + get_exp_val = val_exp + lock_valexp = .TRUE. +!-------------------------- +END SUBROUTINE ioget_expval +!=== +SUBROUTINE restclo (fid) +!--------------------------------------------------------------------- +!- This subroutine closes one or any opened restart file. +!- +!- INPUT +!- +!- fid : File ID in the restcom system (not the netCDF ID)(optional) +!- +!- OUTPUT +!- +!- NONE +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in),OPTIONAL :: fid +!- + INTEGER :: iret,ifnc + CHARACTER(LEN=6) :: n_e + CHARACTER(LEN=3) :: n_f + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (PRESENT(fid)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) & + 'restclo : Closing specified restart file number :', & + fid,netcdf_id(fid,1:2) + ENDIF +!--- + IF (netcdf_id(fid,1) > 0) THEN + iret = NF90_CLOSE(netcdf_id(fid,1)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(fid,1) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + ENDIF + IF (netcdf_id(fid,1) == netcdf_id(fid,2)) THEN + netcdf_id(fid,2) = -1 + ENDIF + netcdf_id(fid,1) = -1 + ENDIF +!--- + IF (netcdf_id(fid,2) > 0) THEN + iret = NF90_CLOSE(netcdf_id(fid,2)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(fid,2) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + ENDIF + netcdf_id(fid,2) = -1 + ENDIF +!--- + ELSE +!--- + IF (l_dbg) WRITE(*,*) 'restclo : Closing all files' +!--- + DO ifnc=1,nb_fi + IF (netcdf_id(ifnc,1) > 0) THEN + iret = NF90_CLOSE(netcdf_id(ifnc,1)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(ifnc,1) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + ENDIF + IF (netcdf_id(ifnc,1) == netcdf_id(ifnc,2)) THEN + netcdf_id(ifnc,2) = -1 + ENDIF + netcdf_id(ifnc,1) = -1 + ENDIF +!----- + IF (netcdf_id(ifnc,2) > 0) THEN + iret = NF90_CLOSE(netcdf_id(ifnc,2)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(ifnc,2) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + END IF + netcdf_id(ifnc,2) = -1 + ENDIF + ENDDO + ENDIF +!--------------------- +END SUBROUTINE restclo +!=== +!----------------- +END MODULE restcom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/92/92d51f63cc984e7183635c36a28885822b1cbeaf.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/92/92d51f63cc984e7183635c36a28885822b1cbeaf.svn-base new file mode 100644 index 0000000..b3fccd0 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/92/92d51f63cc984e7183635c36a28885822b1cbeaf.svn-base @@ -0,0 +1,5173 @@ +MODULE fliocom +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE netcdf +!- +USE defprec +USE calendar, ONLY : lock_calendar,ioget_calendar, & + & ioconf_calendar,ju2ymds,ymds2ju +USE errioipsl, ONLY : ipslerr,ipsldbg +USE stringop, ONLY : strlowercase,str_xfw +!- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: & + & fliocrfd, fliopstc, fliodefv, flioputv, flioputa, & + & flioopfd, flioinqf, flioinqn, fliogstc, & + & flioinqv, fliogetv, flioinqa, fliogeta, & + & fliorenv, fliorena, fliodela, fliocpya, & + & flioqstc, fliosync, flioclo, fliodmpf, & + & flio_dom_set, flio_dom_unset, & + & flio_dom_defset, flio_dom_defunset, flio_dom_definq, & + & flio_dom_file, flio_dom_att +!- +!!-------------------------------------------------------------------- +!! The following PUBLIC parameters (with "flio_" prefix) +!! are used in the module "fliocom" : +!! +!! flio_max_files : maximum number of simultaneously opened files +!! flio_max_dims : maximum number of dimensions for a file +!! flio_max_var_dims : maximum number of dimensions for a variable +!! +!! FLIO_DOM_NONE : "named constant" for no_domain identifier +!! FLIO_DOM_DEFAULT : "named constant" for default_domain identifier +!! +!! flio_i : standard INTEGER external type +!! flio_r : standard REAL external type +!! flio_c : CHARACTER external type +!! flio_i1 : INTEGER*1 external type +!! flio_i2 : INTEGER*2 external type +!! flio_i4 : INTEGER*4 external type +!! flio_r4 : REAL*4 external type +!! flio_r8 : REAL*8 external type +!!-------------------------------------------------------------------- + INTEGER,PARAMETER,PUBLIC :: & + & flio_max_files=100, flio_max_dims=10, flio_max_var_dims=5 + INTEGER,PARAMETER,PUBLIC :: & + & flio_i = -1, flio_r = -2, flio_c =nf90_char, & + & flio_i1=nf90_int1, flio_i2=nf90_int2, flio_i4=nf90_int4, & + & flio_r4=nf90_real4, flio_r8=nf90_real8 +!- + INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_NONE =-1 + INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_DEFAULT = 0 +!- +!!-------------------------------------------------------------------- +!! The "fliocrfd" routine creates a model file +!! which contains the dimensions needed. +!! +!! SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n) +!! +!! INPUT +!! +!! (C) f_n : Name of the file to be created +!! (C) f_d_n(:) : Array of (max nb_fd_mx) names of the dimensions +!! (I) f_d_l(:) : Array of (max nb_fd_mx) lengths of the dimensions +!! For an unlimited dimension, enter a length of -1. +!! Actually, only one unlimited dimension is supported. +!! +!! OUTPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional INPUT arguments +!! +!! (I) id_dom : Identifier of a domain defined by calling +!! "flio_dom_set". If this argument is present, +!! and not equal to FLIO_DOM_NONE, it will be +!! appended to the file name and +!! the attributes describing the related DOMAIN +!! will be put in the created file. +!! This argument can be equal to FLIO_DOM_DEFAULT +!! (see "flio_dom_defset"). +!! (C) mode : String of (case insensitive) blank-separated words +!! defining the mode used to create the file. +!! Supported keywords : REPLACE, 32, 64 +!! If this argument is present with the keyword "REPLACE", +!! the file will be created in mode "CLOBBER", +!! else the file will be created in mode "NOCLOBBER". +!! "32/64" defines the offset mode. +!! The default offset mode is 64 bits. +!! Keywords "NETCDF4" and "CLASSIC" are reserved +!! for future use. +!! +!! Optional OUTPUT arguments +!! +!! (C) c_f_n : Name of the created file. +!! This name can be different of "f_n", +!! if a suffix is added to the original name +!! (".nc" or "DOMAIN_identifier.nc"). +!! The length of "c_f_n" must be sufficient +!! to receive the created file name. +!! +!!- NOTES +!! +!! The names used to identify the spatio-temporal dimensions +!! (dimension associated to a coordinate variable) +!! are the following : +!! +!! Axis Names +!! +!! x 'x[...]' 'lon[...]' +!! y 'y[...]' 'lat[...]' +!! z 'z[...]' 'lev[...]' 'plev[...]' 'depth[...]' +!! t 't' 'time' 'tstep[...]' 'time_counter[...]' +!! +!! Please, apply these rules so that coordinates are +!! correctly defined. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliopstc" routine defines the major coordinates system +!! (spatio-temporal axis) of the model file (created by fliocrfd). +!! +!! SUBROUTINE fliopstc & +!! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & +!! & t_axis,t_init,t_step,t_calendar) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional INPUT arguments +!! +!! (R) x_axis(:) : longitudinal grids +!! (R) x_axis_2d(:,:) : longitudinal grids +!! (R) y_axis(:) : latitudinal grids +!! (R) y_axis_2d(:,:) : latitudinal grids +!! (R) z_axis(:) : vertical grid +!! (I) t_axis(:) : timesteps on the time axis +!! (R) t_init : date in julian days at the beginning +!! (R) t_step : timestep in seconds between t_axis steps +!! (C) t_calendar : calendar +!! +!! [x/y]_axis and [x/y]_axis_2d are mutually exclusive. +!! +!!- NOTES +!! +!! The variables corresponding to the spatio-temporal coordinates +!! are created according to the following characteristics : +!! +!!- Longitude axis x_axis / x_axis_2d +!! Variable name 'lon' / 'nav_lon' +!! Attributes Values +!! 'axis' "X" +!! 'standard_name' "longitude" +!! 'units' "degrees_east" +!! 'valid_min' MINVAL(x_axis/x_axis_2d) +!! 'valid_max' MAXVAL(x_axis/x_axis_2d) +!! +!!- Latitude axis y_axis / y_axis_2d +!! Variable name 'lat' / 'nav_lat' +!! Attributes Values +!! 'axis' "Y" +!! 'standard_name' "latitude" +!! 'units' "degrees_north" +!! 'valid_min' MINVAL(y_axis/y_axis_2d) +!! 'valid_max' MAXVAL(y_axis/y_axis_2d) +!! +!!- Vertical axis z_axis +!! Variable name 'lev' +!! Attributes Values +!! 'axis' "Z" +!! 'standard_name' "model_level_number" +!! 'units' "sigma_level" +!! 'long_name' "Sigma Levels" +!! 'valid_min' MINVAL(z_axis) +!! 'valid_max' MAXVAL(z_axis) +!! +!!- Time axis t_axis +!! Variable name 'time' +!! Attributes Values +!! 'axis' "T" +!! 'standard_name' "time" +!! 'long_name' "time steps" +!! ['calendar' user/default valued] +!! 'units' calculated +!! +!! If you are not satisfied, it is possible +!! to rename variables ("fliorenv") +!! or overload the values of attributes ("flioputa"). +!! Be careful : the new values you use must allow to read variables +!! as coordinates. +!! +!! The dimensions associated to the coordinates variables +!! are searched according to their names (see "fliocrfd") +!!-------------------------------------------------------------------- +!- +INTERFACE fliodefv +!!-------------------------------------------------------------------- +!! The "fliodefv" routines define a variable in a model file. +!! +!! SUBROUTINE fliodefv & +!! & (f_i,v_n,[v_d],v_t, & +!! & axis,standard_name,long_name,units, & +!! & valid_min,valid_max,fillvalue) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to be defined +!! (I) [v_d] : +!! "not present" +!! --> scalar variable +!! "array of one or several integers containing +!! the identifiers of the dimensions of the variable +!! (in the order specified to "fliocrfd" +!! or obtained from "flioopfd")" +!! --> multidimensioned variable +!! +!! Optional INPUT arguments +!! +!! (I) v_t : External type of the variable +!! "present" --> see flio_.. +!! "not present" --> type of standard real +!! (C) axis,standard_name,long_name,units : Attributes +!! (axis should be used only for coordinates) +!! (R) valid_min,valid_max,fillvalue : Attributes +!!-------------------------------------------------------------------- + MODULE PROCEDURE & + & fliodv_r0d,fliodv_rnd +END INTERFACE +!- +INTERFACE flioputv +!!-------------------------------------------------------------------- +!! The "flioputv" routines put a variable (defined by fliodefv) +!! in a model file. +!! +!! SUBROUTINE flioputv (f_i,v_n,v_v,start,count) +!! +!! INPUT +!! +!! (I) f_i : model file identifier +!! (C) v_n : name of the variable to be written +!! (R/I) v_v : scalar or array (up to flio_max_var_dims dimensions) +!! containing the (standard) real/integer values +!! +!! Optional INPUT arguments +!! +!! (I) start(:) : array of integers specifying the index +!! where the first data value will be written +!! (I) count(:) : array of integers specifying the number of +!! indices that will be written along each dimension +!! (not present if v_v is a scalar) +!!-------------------------------------------------------------------- +!?INTEGERS of KIND 1 are not supported on all computers + MODULE PROCEDURE & + & fliopv_i40,fliopv_i41,fliopv_i42,fliopv_i43,fliopv_i44,fliopv_i45, & + & fliopv_i20,fliopv_i21,fliopv_i22,fliopv_i23,fliopv_i24,fliopv_i25, & +!& fliopv_i10,fliopv_i11,fliopv_i12,fliopv_i13,fliopv_i14,fliopv_i15, & + & fliopv_r40,fliopv_r41,fliopv_r42,fliopv_r43,fliopv_r44,fliopv_r45, & + & fliopv_r80,fliopv_r81,fliopv_r82,fliopv_r83,fliopv_r84,fliopv_r85 +END INTERFACE +!- +INTERFACE flioputa +!!-------------------------------------------------------------------- +!! The "flioputa" routines put a value for an attribute +!! in a model file. +!! If this attribute does not exist, it will be created. +!! +!! SUBROUTINE flioputa (f_i,v_n,a_n,a_v) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! If this name is "?", the attribute will be global. +!! (C) a_n : Name of the attribute to be defined. +!! ( ) a_v : scalar or array of real (kind 4 or 8) or integer values, +!! or character string +!!-------------------------------------------------------------------- + MODULE PROCEDURE & + & fliopa_r4_0d,fliopa_r4_1d,fliopa_r8_0d,fliopa_r8_1d, & + & fliopa_i4_0d,fliopa_i4_1d,fliopa_tx_0d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "flioopfd" routine opens an existing model file, +!! and returns the dimensions used in the file and a file identifier. +!! This information can be used to allocate the space needed +!! to extract the data from the file. +!! +!! SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat) +!! +!! INPUT +!! +!! (C) f_n : Name of the file to be opened +!! +!! OUTPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional INPUT arguments +!! +!! (C) mode : Access mode to the file. +!! If this argument is present with the value "WRITE", +!! the file will be accessed in mode "READ-WRITE", +!! else the file will be accessed in mode "READ-ONLY". +!! +!! Optional OUTPUT arguments +!! +!! (I) nb_dim : number of dimensions +!! (I) nb_var : number of variables +!! (I) nb_gat : number of global attributes +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioinqf" routine returns information +!! about an opened model file given its identifier. +!! +!! SUBROUTINE flioinqf & +!! & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional OUTPUT arguments +!! +!! (I) nb_dim : number of dimensions +!! (I) nb_var : number of variables +!! (I) nb_gat : number of global attributes +!! (I) id_uld : identifier of the unlimited dimension (0 if none) +!! (I) id_dim(:) : identifiers of the dimensions +!! (I) ln_dim(:) : lengths of the dimensions +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioinqn" routine returns the names +!! of the entities encountered in an opened model file. +!! +!! SUBROUTINE flioinqn & +!! & (f_i,cn_dim,cn_var,cn_gat,cn_uld, & +!! & id_start,id_count,iv_start,iv_count,ia_start,ia_count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional OUTPUT arguments +!! +!! (C) cn_dim(:) : names of dimensions +!! (C) cn_var(:) : names of variables +!! (C) cn_gat(:) : names of global attributes +!! (C) cn_uld : names of the unlimited dimension +!! +!! Optional INPUT arguments +!! +!! (I) id_start,id_count,iv_start,iv_count,ia_start,ia_count +!! +!! The prefix ( id / iv / ia ) specifies +!! the (dimensions/variables/global attributes) entities +!! +!! The suffix "start" specify the index from which +!! the first name will be retrieved (1 by default) +!! +!! The suffix "count" specifies the number of names to be retrieved +!! (all by default) +!! +!! If a requested entity is not available, a "?" will be returned. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliogstc" routine extracts the major coordinates system +!! (spatio-temporal axis) of the model file (opened by flioopfd). +!! +!! SUBROUTINE fliogstc & +!! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & +!! & t_axis,t_init,t_step,t_calendar, & +!! & x_start,x_count,y_start,y_count, & +!! & z_start,z_count,t_start,t_count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional OUTPUT arguments +!! +!! (R) x_axis(:) : longitudinal grids +!! (R) x_axis_2d(:,:) : longitudinal grids +!! (R) y_axis(:) : latitudinal grids +!! (R) y_axis_2d(:,:) : latitudinal grids +!! (R) z_axis(:) : vertical grid +!! (I) t_axis(:) : timesteps on the time axis +!! (R) t_init : date in julian days at the beginning +!! (R) t_step : timestep in seconds between t_axis steps +!! (C) t_calendar : calendar attribute +!! (the value is "not found" if the attribute +!! is not present in the model file) +!! +!! [x/y]_axis and [x/y]_axis_2d are mutually exclusive. +!! +!! Optional INPUT arguments +!! +!! (I) x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count +!! +!! The prefix (x/y/z/t) specifies the concerned direction. +!! +!! The suffix "start" specify the index from which +!! the first data value will be read (1 by default) +!! +!! The suffix "count" specifies the number of values to be read +!! (all by default) +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioinqv" routine returns information about a model +!! variable given its name. +!! This information can be used to allocate the space needed +!! to extract the variable from the file. +!! +!! SUBROUTINE flioinqv & +!! & (f_i,v_n,l_ex,nb_dims,len_dims,id_dims, & +!! & nb_atts,cn_atts,ia_start,ia_count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of the variable +!! +!! OUTPUT +!! +!! (L) l_ex : Existence of the variable +!! +!! Optional OUTPUT arguments +!! +!! (I) v_t : External type of the variable (see flio_..) +!! (I) nb_dims : number of dimensions of the variable +!! (I) len_dims(:) : list of dimension lengths of the variable +!! (I) id_dims(:) : list of dimension identifiers of the variable +!! (I) nb_atts : number of attributes of the variable +!! (C) cn_atts(:) : names of the attributes +!! +!! Optional INPUT arguments +!! +!! (I) ia_start : index of the first attribute whose the name +!! will be retrieved (1 by default) +!! (I) ia_count : number of names to be retrieved (all by default) +!! +!! If a requested entity is not available, a "?" will be returned. +!!-------------------------------------------------------------------- +!- +INTERFACE fliogetv +!!-------------------------------------------------------------------- +!! The "fliogetv" routines get a variable from a model file. +!! +!! SUBROUTINE fliogetv (f_i,v_n,v_v,start,count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of the variable to be read +!! +!! OUTPUT +!! +!! (R/I) v_v : scalar or array (up to flio_max_var_dims dimensions) +!! that will contain the (standard) real/integer values +!! +!! Optional INPUT arguments +!! +!! (I) start(:) : array of integers specifying the index +!! from which the first data value will be read +!! (I) count(:) : array of integers specifying the number of +!! indices that will be read along each dimension +!! (not present if v_v is a scalar) +!!-------------------------------------------------------------------- +!?INTEGERS of KIND 1 are not supported on all computers + MODULE PROCEDURE & + & fliogv_i40,fliogv_i41,fliogv_i42,fliogv_i43,fliogv_i44,fliogv_i45, & + & fliogv_i20,fliogv_i21,fliogv_i22,fliogv_i23,fliogv_i24,fliogv_i25, & +!& fliogv_i10,fliogv_i11,fliogv_i12,fliogv_i13,fliogv_i14,fliogv_i15, & + & fliogv_r40,fliogv_r41,fliogv_r42,fliogv_r43,fliogv_r44,fliogv_r45, & + & fliogv_r80,fliogv_r81,fliogv_r82,fliogv_r83,fliogv_r84,fliogv_r85 +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "flioinqa" routine returns information about an +!! attribute of a variable given their names, in a model file. +!! Information about a variable includes its existence, +!! and the number of values currently stored in the attribute. +!! For a string-valued attribute, this is the number of +!! characters in the string. +!! This information can be used to allocate the space needed +!! to extract the attribute from the file. +!! +!! SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the concerned attribute. +!! +!! OUTPUT +!! +!! (L) l_ex : existence of the variable +!! +!! Optional OUTPUT arguments +!! +!! (I) a_t : external type of the attribute +!! (I) a_l : number of values of the attribute +!!-------------------------------------------------------------------- +!- +INTERFACE fliogeta +!!-------------------------------------------------------------------- +!! The "fliogeta" routines get a value for an attribute +!! in a model file. +!! +!! SUBROUTINE fliogeta (f_i,v_n,a_n,a_v) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the attribute to be retrieved. +!! ( ) a_v : scalar or array of real (kind 4 or 8) or integer values, +!! or character string +!!-------------------------------------------------------------------- + MODULE PROCEDURE & + & flioga_r4_0d,flioga_r4_1d,flioga_r8_0d,flioga_r8_1d, & + & flioga_i4_0d,flioga_i4_1d,flioga_tx_0d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "fliorenv" routine renames a variable, in a model file. +!! +!! SUBROUTINE fliorenv (f_i,v_o_n,v_n_n) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_o_n : Old name of the variable +!! (C) v_n_n : New name of the variable +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliorena" routine renames an attribute +!! of a variable, in a model file. +!! +!! SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_o_n : Old name of the concerned attribute. +!! (C) a_n_n : New name of the concerned attribute. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliodela" routine deletes an attribute in a model file. +!! +!! SUBROUTINE fliodela (f_i,v_n,a_n) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the concerned attribute. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliocpya" routine copies an attribute +!! from one open model file to another. +!! It can also be used to copy an attribute from +!! one variable to another within the same model file. +!! +!! SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o) +!! +!! INPUT +!! +!! (I) f_i_i : Identifier of the input model file +!! (C) v_n_i : Name of the input variable +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the concerned attribute. +!! (I) f_i_o : Identifier of the output model file +!! It can be the same as the input identifier. +!! (C) v_n_o : Name of the output variable +!! This name is "?" for a global attribute. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioqstc" routine search for a spatio-temporal coordinate +!! in a model file and returns its name. +!! +!! SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) c_type : Type of the coordinate ("x"/"y"/"z"/"t") +!! +!! OUTPUT +!! +!! (L) l_ex : existence of the coordinate +!! (C) c_name : name of the coordinate +!! +!!- NOTES +!! +!! The following rules are used for searching variables +!! which are spatio-temporal coordinates (x/y/z/t). +!! +!!-- Rule 1 : we look for a variable with one dimension +!!-- and which has the same name as its dimension +!! +!!-- Rule 2 : we look for a correct "axis" attribute +!! +!! Axis Axis attribute Number of dimensions +!! (case insensitive) +!! +!! x X 1/2 +!! y Y 1/2 +!! z Z 1 +!! t T 1 +!! +!!-- Rule 3 : we look for a correct "standard_name" attribute +!! +!! Axis Axis attribute Number of dimensions +!! (case insensitive) +!! +!! x longitude 1/2 +!! y latitude 1/2 +!! z model_level_number 1 +!! t time 1 +!! +!!-- Rule 4 : we look for a specific name +!! +!! Axis Names +!! +!! x 'nav_lon' 'lon' 'longitude' +!! y 'nav_lat' 'lat' 'latitude' +!! z 'depth' 'deptht' 'height' 'level' +!! 'lev' 'plev' 'sigma_level' 'layer' +!! t 'time' 'tstep' 'timesteps' +!! +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliosync" routine synchronise one or all opened model files, +!! to minimize data loss in case of abnormal termination. +!! +!! SUBROUTINE fliosync (f_i) +!! +!! Optional INPUT arguments +!! +!! (I) f_i : Model file identifier +!! If this argument is not present, +!! all the opened model files are synchronised. +!--------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioclo" routine closes one or all opened model files +!! and frees the space needed to keep information about the files +!! +!! SUBROUTINE flioclo (f_i) +!! +!! Optional INPUT arguments +!! +!! (I) f_i : Model file identifier +!! If this argument is not present, +!! all the opened model files are closed. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliodmpf" routine dumps a model file +!! and prints the result on the standard output. +!! +!! SUBROUTINE fliodmpf (f_n) +!! +!! INPUT +!! +!! (C) f_n : Name of the model file to be dumped +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! This "flio_dom_set" sets up the domain activity of IOIPSL. +!! It stores all the domain information and allows it to be stored +!! in the model file and change the file names. +!! +!! This routine must be called by the user before opening +!! the model file. +!! +!! SUBROUTINE flio_dom_set & +!! & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom) +!! +!! INPUT +!! +!! (I) dtnb : total number of domains +!! (I) dnb : domain number +!! (I) did(:) : distributed dimensions identifiers +!! (up to 5 dimensions are supported) +!! (I) dsg(:) : total number of points for each dimension +!! (I) dsl(:) : local number of points for each dimension +!! (I) dpf(:) : position of first local point for each dimension +!! (I) dpl(:) : position of last local point for each dimension +!! (I) dhs(:) : start halo size for each dimension +!! (I) dhe(:) : end halo size for each dimension +!! (C) cdnm : Model domain definition name. +!! The names actually supported are : +!! "BOX", "APPLE", "ORANGE". +!! These names are case insensitive. +!! +!! OUTPUT argument +!! +!! (I) id_dom : Model domain identifier +!! +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_unset" routine unsets one or all set domains +!! and frees the space needed to keep information about the domains +!! +!! This routine should be called by the user to free useless domains. +!! +!! SUBROUTINE flio_dom_unset (id_dom) +!! +!! Optional INPUT arguments +!! +!! (I) id_dom : Model domain identifier +!! >=1 & <= dom_max_nb : the domain is closed +!! not present : all the set model domains are unset +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_defset" sets +!! the default domain identifier. +!! +!! SUBROUTINE flio_dom_defset (id_dom) +!! +!! INPUT argument +!! +!! (I) id_dom : Model default domain identifier +!! ( >=1 & <= dom_max_nb ) +!! This identifier will be able to be taken by calling +!! "flio_dom_definq" and used to create model files +!! with the corresponding domain definitions +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_defunset" routine unsets +!! the default domain identifier. +!! +!! SUBROUTINE flio_dom_defunset () +!! +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_definq" routine inquires about +!! the default domain identifier. +!! You should call this procedure to safeguard the current +!! default domain identifier if you wish to use locally +!! another default domain, in order to restore it. +!! +!! SUBROUTINE flio_dom_definq (id_dom) +!! +!! OUTPUT argument +!! +!! (I) id_dom : Model default domain identifier +!! IF no default domain identifier has been set, +!! the returned value is "FLIO_DOM_NONE". +!!-------------------------------------------------------------------- +!- +!--------------------------------------------------------------------- +! This is the data we keep concerning each file we open +!--------------------------------------------------------------------- +!- For each file +!- (I) nw_id(f_i) : index to access at this file +!- (I) nw_nd(f_i) : number of dimensions +!- (I) nw_nv(f_i) : number of variables +!- (I) nw_na(f_i) : number of global attributes +!- (I) nw_un(f_i) : ID of the first unlimited dimension +!- (L) lw_hm(f_i) : for mode handling (.TRUE. define, .FALSE. data) +!- (I) nw_di(:,f_i) : dimension IDs in the file "f_i" +!- (I) nw_dl(:,f_i) : dimension lengths in the file "f_i" +!- (I) nw_ai(:,f_i) : dimension Ids for the axis in the file "f_i" +!--------------------------------------------------------------------- + INTEGER,PARAMETER :: & + & nb_fi_mx=flio_max_files, & + & nb_fd_mx=flio_max_dims, & + & nb_vd_mx=flio_max_var_dims + INTEGER,PARAMETER :: nb_ax_mx=4 +!- + INTEGER,PARAMETER :: k_lon=1, k_lat=2, k_lev=3, k_tim=4 +!- + INTEGER,DIMENSION(nb_fi_mx),SAVE :: & + & nw_id=-1,nw_nd,nw_nv,nw_na,nw_un + LOGICAL,DIMENSION(nb_fi_mx),SAVE :: lw_hm + INTEGER,DIMENSION(nb_fd_mx,nb_fi_mx),SAVE :: nw_di=-1,nw_dl=-1 + INTEGER,DIMENSION(nb_ax_mx,nb_fi_mx),SAVE :: nw_ai=-1 +!- +! Maximum number of simultaneously defined domains + INTEGER,PARAMETER :: dom_max_nb=200 +!- +! Maximum number of distributed dimensions for each domain + INTEGER,PARAMETER :: dom_max_dims=5 +!- +! Default domain identifier + INTEGER,SAVE :: id_def_dom=FLIO_DOM_NONE +!- +! Supported domain definition names + INTEGER,PARAMETER :: n_dns=3, l_dns=7 + CHARACTER(LEN=l_dns),DIMENSION(n_dns),SAVE :: & + & c_dns=(/ "box ","apple ","orange "/) +!- +! DOMAINS related variables + INTEGER,DIMENSION(1:dom_max_nb),SAVE :: & + & d_d_n=-1, d_n_t=0, d_n_c=0 + INTEGER,DIMENSION(1:dom_max_dims,1:dom_max_nb),SAVE :: & + & d_d_i, d_s_g, d_s_l, d_p_f, d_p_l, d_h_s, d_h_e + CHARACTER(LEN=l_dns),DIMENSION(1:dom_max_nb),SAVE :: c_d_t +!- +!=== +CONTAINS +!=== +!- +!--------------------------------------------------------------------- +!- Public procedures +!--------------------------------------------------------------------- +!- +!=== +SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: f_n + CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: f_d_n + INTEGER,DIMENSION(:),INTENT(IN) :: f_d_l + INTEGER,INTENT(OUT) :: f_i + INTEGER,OPTIONAL,INTENT(IN) :: id_dom + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: c_f_n +!- + INTEGER :: i_rc,f_e,idid,ii,m_c,n_u + CHARACTER(LEN=NF90_MAX_NAME) :: f_nw + INTEGER,PARAMETER :: l_string=80,l_word=10 + CHARACTER(LEN=l_string) :: c_string + CHARACTER(LEN=l_word) :: c_word + LOGICAL :: l_ok + INTEGER,PARAMETER :: k_replace=1 + INTEGER,PARAMETER :: k_32=1,k_64=2 +!- !? : Code to be activated for NETCDF4 +!? INTEGER,PARAMETER :: k_netcdf4=1,k_classic=1 + INTEGER,PARAMETER :: n_opt=4 + INTEGER,DIMENSION(n_opt) :: i_opt +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliocrfd - file name : ",TRIM(f_n) + ENDIF +!- +! Search for a free local identifier + f_i = flio_rid() + IF (f_i < 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Too many files.','Please increase nb_fi_mx', & + & 'in module fliocom.f90.') + ENDIF +!- +! Update the name of the file + f_nw = f_n + CALL flio_dom_file (f_nw,id_dom) +!- +! Check the dimensions + IF (SIZE(f_d_l) /= SIZE(f_d_n)) THEN + CALL ipslerr (3,'fliocrfd', & + & 'The number of names is not equal to the number of lengths', & + & 'for the dimensions of the file',TRIM(f_nw)) + ENDIF + IF (SIZE(f_d_l) > nb_fd_mx) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Too many dimensions','to create the file',TRIM(f_nw)) + ENDIF +!- +! Check the mode +!- + i_opt(:)=-1 +!- + IF (PRESENT(mode)) THEN +!--- + IF (LEN_TRIM(mode) > l_string) THEN + CALL ipslerr (3,'fliocrfd', & + & '"mode" argument','too long','to be treated') + ENDIF + c_string = mode(:) + CALL strlowercase (c_string) +!--- + DO + CALL str_xfw (c_string,c_word,l_ok) + IF (l_ok) THEN +!- !? : Code to be activated for NETCDF4 + SELECT CASE (TRIM(c_word)) + CASE('replace') + IF (i_opt(1) > 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Replace option','already','defined') + ELSE + i_opt(1) = k_replace + ENDIF +!? CASE('netcdf4') +!? IF (i_opt(2) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Netcdf4 format','already','defined') +!? ELSE +!? i_opt(2) = k_netcdf4 +!? ENDIF + CASE('32') + IF (i_opt(3) > 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Offset format','already','defined') + ELSE + i_opt(3) = k_32 + ENDIF + CASE('64') + IF (i_opt(3) > 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Offset format','already','defined') + ELSE + i_opt(3) = k_64 + ENDIF +!? CASE('CLASSIC') +!? IF (i_opt(4) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Netcdf4 classic format','already','defined') +!? ELSE +!? i_opt(4) = k_classic +!? ENDIF + CASE DEFAULT + CALL ipslerr (3,'fliocrfd', & + & 'Option '//TRIM(c_word),'not','supported') + END SELECT + ELSE + EXIT + ENDIF + ENDDO + ENDIF +!- + IF (i_opt(1) == k_replace) THEN + m_c = NF90_CLOBBER + ELSE + m_c = NF90_NOCLOBBER + ENDIF +!- +!- Code to be replaced by the following for NETCDF4 +!? IF (i_opt(2) == k_netcdf4) THEN +!? m_c = IOR(m_c,NF90_NETCDF4) +!? IF (i_opt(3) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Netcdf4 format','and offset option','are not compatible') +!? ELSE IF (i_opt(4) == k_classic) THEN +!? m_c = IOR(m_c,NF90_CLASSIC_MODEL) +!? ENDIF +!? LSE IF (i_opt(4) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Classic option','is reserved','for the Netcdf4 format') +!? ELSE + IF (i_opt(3) /= k_32) THEN + m_c = IOR(m_c,NF90_64BIT_OFFSET) + ENDIF +!? ENDIF +!- +! Create file (and enter the definition mode) + i_rc = NF90_CREATE(f_nw,m_c,f_e) + lw_hm(f_i) = .TRUE. + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Could not create file :',TRIM(f_nw), & + & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) ' fliocrfd, external model file-id : ',f_e + ENDIF +!- +! Create dimensions + n_u = 0 + DO ii=1,SIZE(f_d_l) + IF (f_d_l(ii) == -1) THEN + IF (n_u == 0) THEN + i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),NF90_UNLIMITED,idid) + n_u = n_u+1 + ELSE + CALL ipslerr (3,'fliocrfd', & + & 'Can not handle more than one unlimited dimension', & + & 'for file :',TRIM(f_nw)) + ENDIF + ELSE IF (f_d_l(ii) > 0) THEN + i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),f_d_l(ii),idid) + ENDIF + IF ( ((f_d_l(ii) == -1).OR.(f_d_l(ii) > 0)) & + & .AND.(i_rc /= NF90_NOERR) ) THEN + CALL ipslerr (3,'fliocrfd', & + & 'One dimension can not be defined', & + & 'for the file :',TRIM(f_nw)) + ENDIF + ENDDO +!- +! Define "Conventions" global attribute + i_rc = NF90_PUT_ATT(f_e,NF90_GLOBAL,'Conventions',"CF-1.1") +!- +! Add the DOMAIN attributes if needed + CALL flio_dom_att (f_e,id_dom) +!- +! Keep the file information + nw_id(f_i) = f_e + CALL flio_inf (f_e, & + & nb_dims=nw_nd(f_i),id_unlm=nw_un(f_i),nb_atts=nw_na(f_i), & + & nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i)) +!- +! Return the created file name if needed + IF (PRESENT(c_f_n)) THEN + IF (LEN(c_f_n) >= LEN_TRIM(f_nw)) THEN + c_f_n = TRIM(f_nw) + ELSE + CALL ipslerr (3,'fliocrfd', & + & 'the length of "c_f_n" is not sufficient to receive', & + & 'the name of the created file :',TRIM(f_nw)) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) '<-fliocrfd' + ENDIF +!---------------------- +END SUBROUTINE fliocrfd +!=== +SUBROUTINE fliopstc & + & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & + & t_axis,t_init,t_step,t_calendar) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: x_axis,y_axis + REAL,DIMENSION(:,:),OPTIONAL,INTENT(IN) :: x_axis_2d,y_axis_2d + REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: z_axis + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: t_axis + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: t_calendar + REAL,OPTIONAL,INTENT(IN) :: t_init,t_step +!- + INTEGER :: i_rc,f_e + INTEGER :: lonid,latid,levid,timeid + INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss + REAL :: dt,r_ss,v_min,v_max + INTEGER :: k,k_1,k_2 + LOGICAL :: l_tmp + CHARACTER(LEN=20) :: c_tmp1 + CHARACTER(LEN=40) :: c_tmp2 + CHARACTER(LEN=80) :: c_tmp3 +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliopstc" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliopstc',f_i,f_e) +!- +! Validate the coherence of the arguments +!- + IF ( (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) & + & .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'The [x/y]_axis arguments', & + & 'are not coherent :',& + & 'can not handle two [x/y]_axis') + ENDIF +!- + IF ( PRESENT(x_axis).OR.PRESENT(x_axis_2d) & + & .OR.PRESENT(y_axis).OR.PRESENT(y_axis_2d) ) THEN + k_1=nw_ai(k_lon,f_i); k_2=nw_ai(k_lat,f_i); + ENDIF +!- +! Define the longitude axis +!- + IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Longitude axis' + ENDIF +!--- + IF (PRESENT(x_axis)) THEN + IF (SIZE(x_axis) /= nw_dl(k_1,f_i)) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid x_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF + ELSE + IF ( (SIZE(x_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) & + & .OR.(SIZE(x_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid x_axis_2d dimensions :', & + & 'not equal to the dimensions', & + & 'defined at the creation of the file') + ENDIF + ENDIF +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + IF (PRESENT(x_axis)) THEN + i_rc = NF90_DEF_VAR(f_e,"lon",NF90_REAL4, & + & nw_di(k_1,f_i),lonid) + v_min = MINVAL(x_axis) + v_max = MAXVAL(x_axis) + ELSE + i_rc = NF90_DEF_VAR(f_e,"nav_lon",NF90_REAL4, & + & nw_di((/k_1,k_2/),f_i),lonid) + v_min = MINVAL(x_axis_2d) + v_max = MAXVAL(x_axis_2d) + ENDIF + i_rc = NF90_PUT_ATT(f_e,lonid,"axis","X") + i_rc = NF90_PUT_ATT(f_e,lonid,'standard_name',"longitude") + i_rc = NF90_PUT_ATT(f_e,lonid,'units',"degrees_east") + i_rc = NF90_PUT_ATT(f_e,lonid,'valid_min',REAL(v_min,KIND=4)) + i_rc = NF90_PUT_ATT(f_e,lonid,'valid_max',REAL(v_max,KIND=4)) + ENDIF +!- +! Define the Latitude axis +!- + IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Latitude axis' + ENDIF +!--- + IF (PRESENT(y_axis)) THEN + IF (SIZE(y_axis) /= nw_dl(k_2,f_i)) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid y_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF + ELSE + IF ( (SIZE(y_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) & + & .OR.(SIZE(y_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid y_axis_2d dimensions :', & + & 'not equal to the dimensions', & + & 'defined at the creation of the file') + ENDIF + ENDIF +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + IF (PRESENT(y_axis)) THEN + i_rc = NF90_DEF_VAR(f_e,"lat",NF90_REAL4, & + & nw_di(k_2,f_i),latid) + v_min = MINVAL(y_axis) + v_max = MAXVAL(y_axis) + ELSE + i_rc = NF90_DEF_VAR(f_e,"nav_lat",NF90_REAL4, & + & nw_di((/k_1,k_2/),f_i),latid) + v_min = MINVAL(y_axis_2d) + v_max = MAXVAL(y_axis_2d) + ENDIF + i_rc = NF90_PUT_ATT(f_e,latid,"axis","Y") + i_rc = NF90_PUT_ATT(f_e,latid,'standard_name',"latitude") + i_rc = NF90_PUT_ATT(f_e,latid,'units',"degrees_north") + i_rc = NF90_PUT_ATT(f_e,latid,'valid_min',REAL(v_min,KIND=4)) + i_rc = NF90_PUT_ATT(f_e,latid,'valid_max',REAL(v_max,KIND=4)) + ENDIF +!- +! Define the Vertical axis +!- + IF (PRESENT(z_axis)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Vertical axis' + ENDIF +!--- + k_1=nw_ai(k_lev,f_i); +!--- + IF (SIZE(z_axis) /= nw_dl(k_1,f_i)) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid z_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF +!--- + v_min = MINVAL(z_axis) + v_max = MAXVAL(z_axis) +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_DEF_VAR(f_e,'lev',NF90_REAL4, & + & nw_di(k_1,f_i),levid) + i_rc = NF90_PUT_ATT(f_e,levid,"axis","Z") + i_rc = NF90_PUT_ATT(f_e,levid,'standard_name','model_level_number') + i_rc = NF90_PUT_ATT(f_e,levid,'units','sigma_level') + i_rc = NF90_PUT_ATT(f_e,levid,'long_name','Sigma Levels') + i_rc = NF90_PUT_ATT(f_e,levid,'valid_min',REAL(v_min,KIND=4)) + i_rc = NF90_PUT_ATT(f_e,levid,'valid_max',REAL(v_max,KIND=4)) + ENDIF +!- +! Define the Time axis +!- + IF (PRESENT(t_axis).AND.PRESENT(t_init).AND.PRESENT(t_step)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Time axis' + ENDIF +!--- + k_1=nw_ai(k_tim,f_i); +!--- + IF ( (nw_dl(k_1,f_i) /= 0) & + & .AND.(SIZE(t_axis) /= nw_dl(k_1,f_i)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid t_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF +!-- Retrieve the calendar date + CALL lock_calendar (old_status=l_tmp) + IF (PRESENT(t_calendar)) THEN + CALL ioget_calendar (c_tmp1) + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(t_calendar)) + ENDIF + CALL ju2ymds (t_init,j_yy,j_mo,j_dd,r_ss) + IF (PRESENT(t_calendar)) THEN + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(c_tmp1)) + ENDIF + CALL lock_calendar (new_status=l_tmp) +!-- + k=NINT(r_ss) + j_hh=k/3600 + k=k-3600*j_hh + j_mn=k/60 + j_ss=k-60*j_mn +!-- Calculate the step unit + IF (ABS(t_step) >= 604800.) THEN + dt = t_step/604800. + c_tmp2 = 'weeks' + ELSE IF (ABS(t_step) >= 86400.) THEN + dt = t_step/86400. + c_tmp2 = 'days' + ELSE IF (ABS(t_step) >= 3600.) THEN + dt = t_step/3600. + c_tmp2 = 'hours' + ELSE IF (ABS(t_step) >= 60.) THEN + dt = t_step/60. + c_tmp2 = 'minutes' + ELSE + dt = t_step + c_tmp2 = 'seconds' + ENDIF +!--- + c_tmp1 = '' + IF (ABS(dt-NINT(dt)) <= ABS(10.*EPSILON(dt))) THEN + IF (NINT(dt) /= 1) THEN + WRITE (UNIT=c_tmp1,FMT='(I15)') NINT(dt) + ENDIF + ELSE + IF (dt < 1.) THEN + WRITE (UNIT=c_tmp1,FMT='(F8.5)') dt + ELSE + WRITE (UNIT=c_tmp1,FMT='(F17.5)') dt + ENDIF + DO k=LEN_TRIM(c_tmp1),1,-1 + IF (c_tmp1(k:k) /= '0') THEN + EXIT + ELSE + c_tmp1(k:k) = ' ' + ENDIF + ENDDO + ENDIF + c_tmp2 = TRIM(c_tmp1)//' '//TRIM(c_tmp2) + WRITE (UNIT=c_tmp3, & + & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & + & TRIM(ADJUSTL(c_tmp2))//' since ',j_yy,j_mo,j_dd,j_hh,j_mn,j_ss +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_DEF_VAR(f_e,'time',NF90_REAL4, & + & nw_di(k_1,f_i),timeid) + i_rc = NF90_PUT_ATT(f_e,timeid,"axis",'T') + i_rc = NF90_PUT_ATT(f_e,timeid,'standard_name','time') + i_rc = NF90_PUT_ATT(f_e,timeid,'long_name','time steps') + IF (PRESENT(t_calendar)) THEN + i_rc = NF90_PUT_ATT(f_e,timeid,'calendar',TRIM(t_calendar)) + ENDIF + i_rc = NF90_PUT_ATT(f_e,timeid,'units',TRIM(c_tmp3)) + ELSE IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN + CALL ipslerr (3,'fliopstc', & + & 'For time axis and coordinates', & + & 'arguments t_axis AND t_init AND t_step', & + & 'must be PRESENT') + ENDIF +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- +! Create the longitude axis +!- + IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Longitude axis' + ENDIF + IF (PRESENT(x_axis)) THEN + i_rc = NF90_PUT_VAR(f_e,lonid,x_axis(:)) + ELSE + i_rc = NF90_PUT_VAR(f_e,lonid,x_axis_2d(:,:)) + ENDIF + ENDIF +!- +! Create the Latitude axis +!- + IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Latitude axis' + ENDIF + IF (PRESENT(y_axis)) THEN + i_rc = NF90_PUT_VAR(f_e,latid,y_axis(:)) + ELSE + i_rc = NF90_PUT_VAR(f_e,latid,y_axis_2d(:,:)) + ENDIF + ENDIF +!- +! Create the Vertical axis +!- + IF (PRESENT(z_axis)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Vertical axis' + ENDIF + i_rc = NF90_PUT_VAR(f_e,levid,z_axis(:)) + ENDIF +!- +! Create the Time axis +!- + IF (PRESENT(t_axis)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Time axis' + ENDIF + i_rc = NF90_PUT_VAR(f_e,timeid,REAL(t_axis(:))) + ENDIF +!- +! Keep all this information +!- + CALL flio_inf (f_e,nb_vars=nw_nv(f_i),nb_atts=nw_na(f_i)) +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliopstc" + ENDIF +!---------------------- +END SUBROUTINE fliopstc +!=== +SUBROUTINE fliodv_r0d & + & (f_i,v_n,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER,OPTIONAL,INTENT(IN) :: v_t + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & + & axis,standard_name,long_name,units + REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue +!--------------------------------------------------------------------- + CALL flio_udv & + & (f_i,0,v_n,(/0/),v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!------------------------ +END SUBROUTINE fliodv_r0d +!=== +SUBROUTINE fliodv_rnd & + & (f_i,v_n,v_d,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER,DIMENSION(:),INTENT(IN) :: v_d + INTEGER,OPTIONAL,INTENT(IN) :: v_t + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & + & axis,standard_name,long_name,units + REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue +!--------------------------------------------------------------------- + CALL flio_udv & + & (f_i,SIZE(v_d),v_n,v_d,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!------------------------ +END SUBROUTINE fliodv_rnd +!=== +SUBROUTINE flio_udv & + & (f_i,n_d,v_n,v_d,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i,n_d + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER,DIMENSION(:),INTENT(IN) :: v_d + INTEGER,OPTIONAL,INTENT(IN) :: v_t + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & + & axis,standard_name,long_name,units + REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue +!- + INTEGER :: f_e,m_k,i_v,i_rc,ii,idd + INTEGER,DIMENSION(nb_vd_mx) :: a_i +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliodefv ",TRIM(v_n)," ",n_d,"D" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliodefv',f_i,f_e) +!- + IF (n_d > 0) THEN + IF (n_d > nb_vd_mx) THEN + CALL ipslerr (3,'fliodefv', & + & 'Too many dimensions', & + & 'required for the variable',TRIM(v_n)) + ENDIF + ENDIF +!- + DO ii=1,n_d + IF ( (v_d(ii) >= 1).AND.(v_d(ii) <= nb_fd_mx) ) THEN + idd = nw_di(v_d(ii),f_i) + IF (idd > 0) THEN + a_i(ii) = idd + ELSE + CALL ipslerr (3,'fliodefv', & + & 'Invalid dimension identifier','(not defined)',' ') + ENDIF + ELSE + CALL ipslerr (3,'fliodefv', & + & 'Invalid dimension identifier','(not supported)',' ') + ENDIF + ENDDO +!- + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL flio_hdm (f_i,f_e,.TRUE.) +!--- + IF (PRESENT(v_t)) THEN + SELECT CASE (v_t) + CASE(flio_i) + IF (i_std == i_8) THEN +!-------- I8 not yet supported by NETCDF +!-------- m_k = flio_i8 + m_k = flio_i4 + ELSE + m_k = flio_i4 + ENDIF + CASE(flio_r) + IF (r_std == r_8) THEN + m_k = flio_r8 + ELSE + m_k = flio_r4 + ENDIF + CASE(flio_c,flio_i1,flio_i2,flio_i4,flio_r4,flio_r8) + m_k = v_t + CASE DEFAULT + CALL ipslerr (3,'fliodefv', & + & 'Variable '//TRIM(v_n),'External type','not supported') + END SELECT + ELSE IF (r_std == r_8) THEN + m_k = flio_r8 + ELSE + m_k = flio_r4 + ENDIF +!--- + IF (n_d > 0) THEN + i_rc = NF90_DEF_VAR(f_e,v_n,m_k,a_i(1:n_d),i_v) + ELSE + i_rc = NF90_DEF_VAR(f_e,v_n,m_k,i_v) + ENDIF + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliodefv', & + & 'Variable '//TRIM(v_n)//' not defined','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + nw_nv(f_i) = nw_nv(f_i)+1 +!--- + IF (PRESENT(axis)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'axis',TRIM(axis)) + ENDIF + IF (PRESENT(standard_name)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'standard_name',TRIM(standard_name)) + ENDIF + IF (PRESENT(long_name)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'long_name',TRIM(long_name)) + ENDIF + IF (PRESENT(units)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'units',TRIM(units)) + ENDIF + IF (PRESENT(valid_min)) THEN + SELECT CASE (m_k) + CASE(flio_i1,flio_i2) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_2)) + CASE(flio_i4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_4)) + CASE(flio_r4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_4)) + CASE(flio_r8) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_8)) + CASE DEFAULT + CALL ipslerr (2,'fliodefv', & + & 'Variable '//TRIM(v_n),'attribute valid_min', & + & 'not supported for this external type') + END SELECT + ENDIF + IF (PRESENT(valid_max)) THEN + SELECT CASE (m_k) + CASE(flio_i1,flio_i2) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_2)) + CASE(flio_i4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_4)) + CASE(flio_r4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_4)) + CASE(flio_r8) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_8)) + CASE DEFAULT + CALL ipslerr (2,'fliodefv', & + & 'Variable '//TRIM(v_n),'attribute valid_max', & + & 'not supported for this external type') + END SELECT + ENDIF + IF (PRESENT(fillvalue)) THEN + SELECT CASE (m_k) + CASE(flio_i1,flio_i2) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_2)) + CASE(flio_i4) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_4)) + CASE(flio_r4) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_4)) + CASE(flio_r8) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_8)) + CASE DEFAULT + CALL ipslerr (2,'fliodefv', & + & 'Variable '//TRIM(v_n),'attribute fillvalue', & + & 'not supported for this external type') + END SELECT + ENDIF +!--- + ELSE + CALL ipslerr (3,'fliodefv','Variable',TRIM(v_n),'already exist') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliodefv" + ENDIF +!---------------------- +END SUBROUTINE flio_udv +!=== +SUBROUTINE fliopv_i40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_i40 +!=== +SUBROUTINE fliopv_i41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i41 +!=== +SUBROUTINE fliopv_i42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i42 +!=== +SUBROUTINE fliopv_i43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i43 +!=== +SUBROUTINE fliopv_i44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i44 +!=== +SUBROUTINE fliopv_i45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i45 +!=== +SUBROUTINE fliopv_i20 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_20=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_i20 +!=== +SUBROUTINE fliopv_i21 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_21=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i21 +!=== +SUBROUTINE fliopv_i22 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_22=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i22 +!=== +SUBROUTINE fliopv_i23 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_23=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i23 +!=== +SUBROUTINE fliopv_i24 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_24=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i24 +!=== +SUBROUTINE fliopv_i25 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_25=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i25 +!=== +!?INTEGERS of KIND 1 are not supported on all computers +!?SUBROUTINE fliopv_i10 (f_i,v_n,v_v,start) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_10=v_v,start=start) +!?!------------------------ +!?END SUBROUTINE fliopv_i10 +!?!=== +!?SUBROUTINE fliopv_i11 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_11=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i11 +!?!=== +!?SUBROUTINE fliopv_i12 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_12=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i12 +!?!=== +!?SUBROUTINE fliopv_i13 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_13=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i13 +!?!=== +!?SUBROUTINE fliopv_i14 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_14=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i14 +!?!=== +!?SUBROUTINE fliopv_i15 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_15=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i15 +!=== +SUBROUTINE fliopv_r40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_r40 +!=== +SUBROUTINE fliopv_r41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r41 +!=== +SUBROUTINE fliopv_r42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r42 +!=== +SUBROUTINE fliopv_r43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r43 +!=== +SUBROUTINE fliopv_r44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r44 +!=== +SUBROUTINE fliopv_r45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r45 +!=== +SUBROUTINE fliopv_r80 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_80=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_r80 +!=== +SUBROUTINE fliopv_r81 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_81=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r81 +!=== +SUBROUTINE fliopv_r82 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_82=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r82 +!=== +SUBROUTINE fliopv_r83 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_83=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r83 +!=== +SUBROUTINE fliopv_r84 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_84=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r84 +!=== +SUBROUTINE fliopv_r85 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_85=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r85 +!=== +SUBROUTINE flio_upv & + & (f_i,v_n, & + & i_40,i_41,i_42,i_43,i_44,i_45, & + & i_20,i_21,i_22,i_23,i_24,i_25, & +!? & i_10,i_11,i_12,i_13,i_14,i_15, & + & r_40,r_41,r_42,r_43,r_44,r_45, & + & r_80,r_81,r_82,r_83,r_84,r_85, & + & start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(IN),OPTIONAL :: i_40 + INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN),OPTIONAL :: i_41 + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_42 + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_43 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_44 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_45 + INTEGER(KIND=i_2),INTENT(IN),OPTIONAL :: i_20 + INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN),OPTIONAL :: i_21 + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_22 + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_23 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_24 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_25 +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER(KIND=i_1),INTENT(IN),OPTIONAL :: i_10 +!?INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN),OPTIONAL :: i_11 +!?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_12 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_13 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_14 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_15 + REAL(KIND=r_4),INTENT(IN),OPTIONAL :: r_40 + REAL(KIND=r_4),DIMENSION(:),INTENT(IN),OPTIONAL :: r_41 + REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_42 + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_43 + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_44 + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_45 + REAL(KIND=r_8),INTENT(IN),OPTIONAL :: r_80 + REAL(KIND=r_8),DIMENSION(:),INTENT(IN),OPTIONAL :: r_81 + REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_82 + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_83 + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_84 + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_85 + INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count +!- + INTEGER :: f_e,i_v,i_rc + CHARACTER(LEN=5) :: cvr_d +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + IF (PRESENT(i_40)) THEN; cvr_d = "I1 0D"; + ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D"; + ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D"; + ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D"; + ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D"; + ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D"; + ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D"; + ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D"; + ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D"; + ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D"; + ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D"; + ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D"; +!? ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D"; +!? ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D"; +!? ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D"; +!? ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D"; +!? ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D"; +!? ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D"; + ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D"; + ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D"; + ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D"; + ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D"; + ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D"; + ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D"; + ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D"; + ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D"; + ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D"; + ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D"; + ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D"; + ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D"; + ENDIF + WRITE(*,*) "->flioputv ",TRIM(v_n)," ",TRIM(cvr_d) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioputv',f_i,f_e) +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc == NF90_NOERR) THEN + IF (PRESENT(i_40)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_40,start=start) + ELSE IF (PRESENT(i_41)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_41,start=start,count=count) + ELSE IF (PRESENT(i_42)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_42,start=start,count=count) + ELSE IF (PRESENT(i_43)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_43,start=start,count=count) + ELSE IF (PRESENT(i_44)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_44,start=start,count=count) + ELSE IF (PRESENT(i_45)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_45,start=start,count=count) + ELSE IF (PRESENT(i_20)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_20,start=start) + ELSE IF (PRESENT(i_21)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_21,start=start,count=count) + ELSE IF (PRESENT(i_22)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_22,start=start,count=count) + ELSE IF (PRESENT(i_23)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_23,start=start,count=count) + ELSE IF (PRESENT(i_24)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_24,start=start,count=count) + ELSE IF (PRESENT(i_25)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_25,start=start,count=count) +!? ELSE IF (PRESENT(i_10)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_10,start=start) +!? ELSE IF (PRESENT(i_11)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_11,start=start,count=count) +!? ELSE IF (PRESENT(i_12)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_12,start=start,count=count) +!? ELSE IF (PRESENT(i_13)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_13,start=start,count=count) +!? ELSE IF (PRESENT(i_14)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_14,start=start,count=count) +!? ELSE IF (PRESENT(i_15)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_15,start=start,count=count) + ELSE IF (PRESENT(r_40)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_40,start=start) + ELSE IF (PRESENT(r_41)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_41,start=start,count=count) + ELSE IF (PRESENT(r_42)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_42,start=start,count=count) + ELSE IF (PRESENT(r_43)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_43,start=start,count=count) + ELSE IF (PRESENT(r_44)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_44,start=start,count=count) + ELSE IF (PRESENT(r_45)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_45,start=start,count=count) + ELSE IF (PRESENT(r_80)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_80,start=start) + ELSE IF (PRESENT(r_81)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_81,start=start,count=count) + ELSE IF (PRESENT(r_82)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_82,start=start,count=count) + ELSE IF (PRESENT(r_83)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_83,start=start,count=count) + ELSE IF (PRESENT(r_84)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_84,start=start,count=count) + ELSE IF (PRESENT(r_85)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_85,start=start,count=count) + ENDIF + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioputv', & + & 'Variable '//TRIM(v_n)//' not put','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + ELSE + CALL ipslerr (3,'flioputv','Variable',TRIM(v_n),'not defined') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioputv" + ENDIF +!---------------------- +END SUBROUTINE flio_upv +!=== +SUBROUTINE fliopa_r4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avr4=(/a_v/)) +!-------------------------- +END SUBROUTINE fliopa_r4_0d +!=== +SUBROUTINE fliopa_r4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),DIMENSION(:),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr4=a_v) +!-------------------------- +END SUBROUTINE fliopa_r4_1d +!=== +SUBROUTINE fliopa_r8_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avr8=(/a_v/)) +!-------------------------- +END SUBROUTINE fliopa_r8_0d +!=== +SUBROUTINE fliopa_r8_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),DIMENSION(:),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr8=a_v) +!-------------------------- +END SUBROUTINE fliopa_r8_1d +!=== +SUBROUTINE fliopa_i4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avi4=(/a_v/)) +!-------------------------- +END SUBROUTINE fliopa_i4_0d +!=== +SUBROUTINE fliopa_i4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),DIMENSION(:),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avi4=a_v) +!-------------------------- +END SUBROUTINE fliopa_i4_1d +!=== +SUBROUTINE fliopa_tx_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + CHARACTER(LEN=*),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avtx=a_v) +!-------------------------- +END SUBROUTINE fliopa_tx_0d +!=== +SUBROUTINE flio_upa (f_i,l_a,v_n,a_n,avr4,avr8,avi4,avtx) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i,l_a + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr4 + REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr8 + INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avi4 + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: avtx +!- + INTEGER :: f_e,i_v,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioputa ",TRIM(v_n)," ",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioputa',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioputa', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a) + IF ( (i_v == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN + nw_na(f_i) = nw_na(f_i)+1 + ENDIF + CALL flio_hdm (f_i,f_e,.TRUE.) + IF (PRESENT(avr4)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr4(1:l_a)) + ELSE IF (PRESENT(avr8)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr8(1:l_a)) + ELSE IF (PRESENT(avi4)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avi4(1:l_a)) + ELSE IF (PRESENT(avtx)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,TRIM(avtx)) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioputa" + ENDIF +!---------------------- +END SUBROUTINE flio_upa +!=== +SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: f_n + INTEGER,INTENT(OUT) :: f_i + CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: mode + INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat +!- + INTEGER :: i_rc,f_e,m_c +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) '->flioopfd, file name : ',TRIM(f_n) + ENDIF +!- +! Search for a free local identifier +!- + f_i = flio_rid() + IF (f_i < 0) THEN + CALL ipslerr (3,'flioopfd', & + 'Too many files.','Please increase nb_fi_mx', & + 'in module fliocom.f90.') + ENDIF +!- +! Check the mode +!- + IF (PRESENT(mode)) THEN + IF (TRIM(mode) == "WRITE") THEN + m_c = NF90_WRITE + ELSE + m_c = NF90_NOWRITE + ENDIF + ELSE + m_c = NF90_NOWRITE + ENDIF +!- +! Open the file. +!- + i_rc = NF90_OPEN(TRIM(f_n),m_c,f_e) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioopfd', & + & 'Could not open file :',TRIM(f_n), & + & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) ' flioopfd, model file-id : ',f_e + ENDIF +!- +! Retrieve and keep information about the file +!- + nw_id(f_i) = f_e + lw_hm(f_i) = .FALSE. + CALL flio_inf (f_e, & + & nb_dims=nw_nd(f_i),nb_vars=nw_nv(f_i), & + & nb_atts=nw_na(f_i),id_unlm=nw_un(f_i), & + & nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i)) +!- +! Return information to the user +!- + IF (PRESENT(nb_dim)) THEN + nb_dim = nw_nd(f_i) + ENDIF + IF (PRESENT(nb_var)) THEN + nb_var = nw_nv(f_i) + ENDIF + IF (PRESENT(nb_gat)) THEN + nb_gat = nw_na(f_i) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,'(" flioopfd - dimensions :",/,(5(1X,I10),:))') & + & nw_dl(:,f_i) + WRITE(*,*) "<-flioopfd" + ENDIF +!---------------------- +END SUBROUTINE flioopfd +!=== +SUBROUTINE flioinqf & + & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat,id_uld + INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: id_dim,ln_dim +!- + INTEGER :: lll +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqf" + ENDIF +!- + IF ( (f_i < 1).OR.(f_i > nb_fi_mx) ) THEN + CALL ipslerr (2,'flioinqf', & + & 'Invalid file identifier',' ',' ') + ELSE IF (nw_id(f_i) <= 0) THEN + CALL ipslerr (2,'flioinqf', & + & 'Unable to inquire about the file :','probably','not opened') + ELSE + IF (PRESENT(nb_dim)) THEN + nb_dim = nw_nd(f_i) + ENDIF + IF (PRESENT(nb_var)) THEN + nb_var = nw_nv(f_i) + ENDIF + IF (PRESENT(nb_gat)) THEN + nb_gat = nw_na(f_i) + ENDIF + IF (PRESENT(id_uld)) THEN + id_uld = nw_un(f_i) + ENDIF + IF (PRESENT(id_dim)) THEN + lll = SIZE(id_dim) + IF (lll < nw_nd(f_i)) THEN + CALL ipslerr (2,'flioinqf', & + & 'Only the first identifiers', & + & 'of the dimensions','will be returned') + ENDIF + lll=MIN(SIZE(id_dim),nw_nd(f_i)) + id_dim(1:lll) = nw_di(1:lll,f_i) + ENDIF + IF (PRESENT(ln_dim)) THEN + lll = SIZE(ln_dim) + IF (lll < nw_nd(f_i)) THEN + CALL ipslerr (2,'flioinqf', & + & 'Only the first lengths', & + & 'of the dimensions','will be returned') + ENDIF + lll=MIN(SIZE(ln_dim),nw_nd(f_i)) + ln_dim(1:lll) = nw_dl(1:lll,f_i) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqf" + ENDIF +!---------------------- +END SUBROUTINE flioinqf +!=== +SUBROUTINE flioinqn & + & (f_i,cn_dim,cn_var,cn_gat,cn_uld, & + & id_start,id_count,iv_start,iv_count,ia_start,ia_count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: & + & cn_dim,cn_var,cn_gat + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: & + & cn_uld + INTEGER,OPTIONAL,INTENT(IN) :: & + & id_start,id_count,iv_start,iv_count,ia_start,ia_count +!- + INTEGER :: f_e,i_s,i_w,iws,iwc,i_rc + LOGICAL :: l_ok +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqn" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioinqn',f_i,f_e) +!- + IF (PRESENT(cn_dim)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_dim) + DO i_w=1,i_s + cn_dim(i_w)(:) = '?' + ENDDO + IF (PRESENT(id_start)) THEN + iws = id_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(id_count)) THEN + iwc = id_count + ELSE + iwc = nw_nd(f_i) + ENDIF + IF (iws > nw_nd(f_i)) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested dimensions', & + & 'is greater than the number of dimensions', & + & 'in the file') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested dimensions', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF ((iws+iwc-1) > nw_nd(f_i)) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of requested dimensions', & + & 'is greater than the number of dimensions', & + & 'in the file') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of dimensions to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first dimensions of the file will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The number of requested dimensions', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,nw_nd(f_i)-iws+1) + i_rc = NF90_INQUIRE_DIMENSION(f_e,i_w+iws-1,name=cn_dim(i_w)) + ENDDO + ENDIF + ENDIF +!- + IF (PRESENT(cn_var)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_var) + DO i_w=1,i_s + cn_var(i_w)(:) = '?' + ENDDO + IF (PRESENT(iv_start)) THEN + iws = iv_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(iv_count)) THEN + iwc = iv_count + ELSE + iwc = nw_nv(f_i) + ENDIF + IF (iws > nw_nv(f_i)) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested variables', & + & 'is greater than the number of variables', & + & 'in the file') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested variables', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF ((iws+iwc-1) > nw_nv(f_i)) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of requested variables', & + & 'is greater than the number of variables', & + & 'in the file') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of variables to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first variables of the file will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The number of requested variables', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,nw_nv(f_i)-iws+1) + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_w+iws-1,name=cn_var(i_w)) + ENDDO + ENDIF + ENDIF +!- + IF (PRESENT(cn_gat)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_gat) + DO i_w=1,i_s + cn_gat(i_w)(:) = '?' + ENDDO + IF (PRESENT(ia_start)) THEN + iws = ia_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(ia_count)) THEN + iwc = ia_count + ELSE + iwc = nw_na(f_i) + ENDIF + IF (iws > nw_na(f_i)) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested global attributes', & + & 'is greater than the number of global attributes', & + & 'in the file') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested global attributes', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF ((iws+iwc-1) > nw_na(f_i)) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of requested global attributes', & + & 'is greater than the number of global attributes', & + & 'in the file') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of global attributes to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first global attributes of the file will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The number of requested global attributes', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,nw_na(f_i)-iws+1) + i_rc = NF90_INQ_ATTNAME(f_e, & + & NF90_GLOBAL,i_w+iws-1,name=cn_gat(i_w)) + ENDDO + ENDIF + ENDIF +!- + IF (PRESENT(cn_uld)) THEN + cn_uld = '?' + IF (nw_un(f_i) > 0) THEN + i_rc = NF90_INQUIRE_DIMENSION(f_e,nw_un(f_i),name=cn_uld) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqn" + ENDIF +!---------------------- +END SUBROUTINE flioinqn +!=== +SUBROUTINE fliogstc & + & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & + & t_axis,t_init,t_step,t_calendar, & + & x_start,x_count,y_start,y_count, & + & z_start,z_count,t_start,t_count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + REAL,DIMENSION(:),OPTIONAL,INTENT(OUT) :: x_axis,y_axis + REAL,DIMENSION(:,:),OPTIONAL,INTENT(OUT) :: x_axis_2d,y_axis_2d + REAL,DIMENSION(:),OPTIONAL,INTENT(OUT) :: z_axis + INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: t_axis + REAL,OPTIONAL,INTENT(OUT) :: t_init,t_step + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: t_calendar + INTEGER,OPTIONAL,INTENT(IN) :: & + & x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count +!- + INTEGER :: i_rc,f_e,i_v,it_t,nbdim,kv + INTEGER :: m_x,i_x,l_x,m_y,i_y,l_y,m_z,i_z,l_z,m_t,i_t,l_t + CHARACTER(LEN=NF90_MAX_NAME) :: name + CHARACTER(LEN=80) :: units + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=1) :: c_1 + REAL :: r_yy,r_mo,r_dd,r_ss,dtv,dtn + INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss + LOGICAL :: l_ok,l_tmp +!- + REAL,DIMENSION(:),ALLOCATABLE :: v_tmp +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliogstc" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliogstc',f_i,f_e) +!- +! Validate the coherence of the arguments +!- + IF ( (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) & + & .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN + CALL ipslerr (3,'fliogstc', & + & 'The [x/y]_axis arguments', & + & 'are not coherent :',& + & 'can not handle two [x/y]_axis') + ENDIF +!- +! Retrieve spatio-temporal dimensions +!- + IF (nw_ai(k_lon,f_i) > 0) THEN + m_x = nw_dl(nw_ai(k_lon,f_i),f_i); + ELSE + m_x = -1; + ENDIF + IF (nw_ai(k_lat,f_i) > 0) THEN + m_y = nw_dl(nw_ai(k_lat,f_i),f_i); + ELSE + m_y = -1; + ENDIF + IF (nw_ai(k_lev,f_i) > 0) THEN + m_z = nw_dl(nw_ai(k_lev,f_i),f_i); + ELSE + m_z = -1; + ENDIF + IF (nw_ai(k_tim,f_i) > 0) THEN + m_t = nw_dl(nw_ai(k_tim,f_i),f_i); + ELSE + m_t = -1; + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,'(" fliogstc - dimensions :",/,(5(1X,I10),:))') & + & m_x,m_y,m_z,m_t + ENDIF +!- +! Initialize the x-y indices +!- + IF ( PRESENT(x_axis) & + & .OR.PRESENT(x_axis_2d) & + & .OR.PRESENT(y_axis_2d) ) THEN + IF (PRESENT(x_start)) THEN + i_x = x_start + ELSE + i_x = 1 + ENDIF + IF (PRESENT(x_count)) THEN + l_x = x_count + ELSE + l_x = m_x-i_x+1 + ENDIF + ENDIF + IF ( PRESENT(y_axis) & + & .OR.PRESENT(y_axis_2d) & + & .OR.PRESENT(x_axis_2d) ) THEN + IF (PRESENT(y_start)) THEN + i_y = y_start + ELSE + i_y = 1 + ENDIF + IF (PRESENT(y_count)) THEN + l_y = y_count + ELSE + l_y = m_y-i_y+1 + ENDIF + ENDIF + IF (PRESENT(x_axis)) THEN + IF (m_x <= 0) THEN + CALL ipslerr (3,'fliogstc', & + & 'Requested x_axis', & + & 'but the coordinate is not present','in the file') + ELSE IF ((i_x+l_x-1) > m_x) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the x_axis', & + & 'is greater than the size of the coordinate','in the file') + ENDIF + ENDIF + IF (PRESENT(y_axis)) THEN + IF (m_y <= 0) THEN + CALL ipslerr (3,'fliogstc', & + & 'Requested y_axis', & + & 'but the coordinate is not present','in the file') + ELSE IF ((i_y+l_y-1) > m_y) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the y_axis', & + & 'is greater than the size of the coordinate','in the file') + ENDIF + ENDIF + IF (PRESENT(x_axis_2d).OR.PRESENT(y_axis_2d) )THEN + IF ( (m_x <= 0).OR.(m_y <= 0) ) THEN + CALL ipslerr (3,'fliogstc', & + & 'Requested [x/y]_axis_2d', & + & 'but the coordinates are not iboth present','in the file') + ELSE IF ( ((i_x+l_x-1) > m_x).OR.((i_y+l_y-1) > m_y) ) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the [x/y]_axis_2d', & + & 'is greater than the size of the coordinate','in the file') + ENDIF + ENDIF +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- +! Extracting the x coordinate, if needed +!- + IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN + CALL flio_qax (f_i,'x',i_v,nbdim) + IF (i_v > 0) THEN + IF (nbdim == 1) THEN + IF (PRESENT(x_axis)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,x_axis, & + & start=(/i_x/),count=(/l_x/)) + ELSE + ALLOCATE(v_tmp(l_x)) + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_x/),count=(/l_x/)) + DO kv=1,l_y + x_axis_2d(:,kv) = v_tmp(:) + ENDDO + DEALLOCATE(v_tmp) + ENDIF + ELSE IF (nbdim == 2) THEN + IF (PRESENT(x_axis)) THEN + l_ok = .TRUE. + IF (l_y > 1) THEN + ALLOCATE(v_tmp(l_y)) + DO kv=i_x,i_x+l_x-1 + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/kv,i_y/),count=(/1,l_y/)) + IF (ANY(v_tmp(2:l_y) /= v_tmp(1))) THEN + l_ok = .FALSE. + EXIT + ENDIF + ENDDO + DEALLOCATE(v_tmp) + ENDIF + IF (l_ok) THEN + i_rc = NF90_GET_VAR(f_e,i_v,x_axis, & + & start=(/i_x,i_y/),count=(/l_x,1/)) + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Requested 1D x_axis', & + & 'which have 2 not regular dimensions', & + & 'in the file') + ENDIF + ELSE + i_rc = NF90_GET_VAR(f_e,i_v,x_axis_2d, & + & start=(/i_x,i_y/),count=(/l_x,l_y/)) + ENDIF + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Can not handle x_axis', & + & 'that have more than 2 dimensions', & + & 'in the file') + ENDIF + ELSE + CALL ipslerr (3,'fliogstc','No x_axis found','in the file',' ') + ENDIF + ENDIF +!- +! Extracting the y coordinate, if needed +!- + IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN + CALL flio_qax (f_i,'y',i_v,nbdim) + IF (i_v > 0) THEN + IF (nbdim == 1) THEN + IF (PRESENT(y_axis)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,y_axis, & + & start=(/i_y/),count=(/l_y/)) + ELSE + ALLOCATE(v_tmp(l_y)) + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_y/),count=(/l_y/)) + DO kv=1,l_x + y_axis_2d(kv,:) = v_tmp(:) + ENDDO + DEALLOCATE(v_tmp) + ENDIF + ELSE IF (nbdim == 2) THEN + IF (PRESENT(y_axis)) THEN + l_ok = .TRUE. + IF (l_x > 1) THEN + ALLOCATE(v_tmp(l_x)) + DO kv=i_y,i_y+l_y-1 + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_x,kv/),count=(/l_x,1/)) + IF (ANY(v_tmp(2:l_x) /= v_tmp(1))) THEN + l_ok = .FALSE. + EXIT + ENDIF + ENDDO + DEALLOCATE(v_tmp) + ENDIF + IF (l_ok) THEN + i_rc = NF90_GET_VAR(f_e,i_v,y_axis, & + & start=(/i_x,i_y/),count=(/1,l_y/)) + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Requested 1D y_axis', & + & 'which have 2 not regular dimensions', & + & 'in the file') + ENDIF + ELSE + i_rc = NF90_GET_VAR(f_e,i_v,y_axis_2d, & + & start=(/i_x,i_y/),count=(/l_x,l_y/)) + ENDIF + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Can not handle y axis', & + & 'that have more than 2 dimensions', & + & 'in the file') + ENDIF + ELSE + CALL ipslerr (3,'fliogstc','No y_axis found','in the file',' ') + ENDIF + ENDIF +!- +! Extracting the z coordinate, if needed +!- + IF (PRESENT(z_axis)) THEN + IF (PRESENT(z_start)) THEN + i_z = z_start + ELSE + i_z = 1 + ENDIF + IF (PRESENT(z_count)) THEN + l_z = z_count + ELSE + l_z = m_z-i_z+1 + ENDIF + IF ((i_z+l_z-1) > m_z) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the z axis', & + & 'is greater than the size of the coordinate',& + & 'in the file') + ENDIF + CALL flio_qax (f_i,'z',i_v,nbdim) + IF (i_v > 0) THEN + IF (nbdim == 1) THEN + i_rc = NF90_GET_VAR(f_e,i_v,z_axis, & + & start=(/i_z/),count=(/l_z/)) + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Can not handle z_axis', & + & 'that have more than 1 dimension', & + & 'in the file') + ENDIF + ELSE + CALL ipslerr (3,'fliogstc','No z_axis found','in the file',' ') + ENDIF + ENDIF +!- +! Extracting the t coordinate, if needed +!- + IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN + CALL flio_qax (f_i,'t',i_v,nbdim) + IF (i_v < 0) THEN + CALL ipslerr (3,'fliogstc','No t_axis found','in the file',' ') + ENDIF +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliogstc - get time details' + ENDIF +!--- +!-- Get all the details for the time +!-- Prefered method is '"time_steps" since' +!--- + name='' + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,name=name) + units='' + i_rc = NF90_GET_ATT(f_e,i_v,'units',units) + IF (INDEX(units,' since ') > 0) THEN + it_t = 1 + ELSE IF (INDEX(name,'tstep') > 0) THEN + it_t = 2 + ELSE + it_t = 0; + ENDIF + ENDIF +!- +! Extracting the t coordinate, if needed +!- + IF (PRESENT(t_axis)) THEN + IF (PRESENT(t_start)) THEN + i_t = t_start + ELSE + i_t = 1 + ENDIF + IF (PRESENT(t_count)) THEN + l_t = t_count + ELSE + l_t = m_t-i_t+1 + ENDIF + IF ((i_t+l_t-1) > m_t) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the t axis', & + & 'is greater than the size of the coordinate',& + & 'in the file') + ENDIF + ALLOCATE(v_tmp(l_t)) + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_t/),count=(/l_t/)) + t_axis(1:l_t) = NINT(v_tmp(1:l_t)) + DEALLOCATE(v_tmp) +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliogstc - first time : ',t_axis(1:1) + ENDIF + ENDIF +!- +! Extracting the time at the beginning, if needed +!- + IF (PRESENT(t_init)) THEN +!-- Find the calendar + CALL lock_calendar (old_status=l_tmp) + CALL ioget_calendar (c_tmp) + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units) + IF (i_rc == NF90_NOERR) THEN + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(units)) + ENDIF + IF (it_t == 1) THEN + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'units',units) + units = units(INDEX(units,' since ')+7:LEN_TRIM(units)) + READ (units,'(I4.4,5(A,I2.2))') & + & j_yy,c_1,j_mo,c_1,j_dd,c_1,j_hh,c_1,j_mn,c_1,j_ss + r_ss = j_hh*3600.+j_mn*60.+j_ss + CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init) + ELSE IF (it_t == 2) THEN + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'year0',r_yy) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'month0',r_mo) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'day0',r_dd) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'sec0',r_ss) + j_yy = NINT(r_yy); j_mo = NINT(r_mo); j_dd = NINT(r_dd); + CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init) + ELSE + t_init = 0. + ENDIF + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(c_tmp)) + CALL lock_calendar (new_status=l_tmp) + IF (l_dbg) THEN + WRITE(*,*) ' fliogstc - time_type : ' + WRITE(*,*) it_t + WRITE(*,*) ' fliogstc - year month day second t_init : ' + WRITE(*,*) j_yy,j_mo,j_dd,r_ss,t_init + ENDIF + ENDIF +!- +! Extracting the timestep in seconds, if needed +!- + IF (PRESENT(t_step)) THEN + IF (it_t == 1) THEN + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'units',units) + units = ADJUSTL(units(1:INDEX(units,' since ')-1)) + dtn = 1. + IF (INDEX(units,"week") /= 0) THEN + kv = INDEX(units,"week") + dtv = 604800. + ELSE IF (INDEX(units,"day") /= 0) THEN + kv = INDEX(units,"day") + dtv = 86400. + ELSE IF (INDEX(units,"h") /= 0) THEN + kv = INDEX(units,"h") + dtv = 3600. + ELSE IF (INDEX(units,"min") /= 0) THEN + kv = INDEX(units,"min") + dtv = 60. + ELSE IF (INDEX(units,"sec") /= 0) THEN + kv = INDEX(units,"sec") + dtv = 1. + ELSE IF (INDEX(units,"timesteps") /= 0) THEN + kv = INDEX(units,"timesteps") + i_rc = NF90_GET_ATT(f_e,i_v,'tstep_sec',dtv) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogstc','"timesteps" value', & + & 'not found','in the file') + ENDIF + ELSE + kv = 1 + dtv = 1. + ENDIF + IF (kv > 1) THEN + READ (unit=units(1:kv-1),FMT=*) dtn + ENDIF + t_step = dtn*dtv + ELSE IF (it_t == 2) THEN + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'delta_tstep_sec',t_step) + ELSE + t_step = 1. + ENDIF + ENDIF +!- +! Extracting the calendar attribute, if needed +!- + IF (PRESENT(t_calendar)) THEN + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units) + IF (i_rc == NF90_NOERR) THEN + t_calendar = units + ELSE + t_calendar = "not found" + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliogstc" + ENDIF +!---------------------- +END SUBROUTINE fliogstc +!=== +SUBROUTINE flioinqv & + & (f_i,v_n,l_ex,v_t,nb_dims,len_dims,id_dims, & + & nb_atts,cn_atts,ia_start,ia_count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + LOGICAL,INTENT(OUT) :: l_ex + INTEGER,OPTIONAL,INTENT(OUT) :: v_t,nb_dims,nb_atts + INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: len_dims,id_dims + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cn_atts + INTEGER,OPTIONAL,INTENT(IN) :: ia_start,ia_count +!- + INTEGER :: f_e,i_v,n_w,i_s,i_w,iws,iwc,i_rc + LOGICAL :: l_ok + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dim_ids +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqv ",TRIM(v_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioinqv',f_i,f_e) +!- + i_v = -1 + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) +!- + l_ex = ( (i_v >= 0).AND.(i_rc == NF90_NOERR) ) +!- + IF (l_ex) THEN + IF (PRESENT(v_t)) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,xtype=v_t) + ENDIF + n_w = -1 + IF (PRESENT(nb_dims).OR.PRESENT(len_dims)) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v, & + & ndims=n_w,dimids=dim_ids) + IF (PRESENT(nb_dims)) THEN + nb_dims = n_w + ENDIF + IF (PRESENT(len_dims)) THEN + i_s = SIZE(len_dims) + len_dims(:) = -1 + IF (i_s < n_w) THEN + CALL ipslerr (2,'flioinqv', & + & 'Only the first dimensions of the variable', & + & TRIM(v_n),'will be returned') + ENDIF + DO i_w=1,MIN(n_w,i_s) + i_rc = NF90_INQUIRE_DIMENSION(f_e,dim_ids(i_w), & + & len=len_dims(i_w)) + ENDDO + ENDIF + IF (PRESENT(id_dims)) THEN + i_s = SIZE(id_dims) + id_dims(:) = -1 + IF (i_s < n_w) THEN + CALL ipslerr (2,'flioinqv', & + & 'The number of dimensions to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first dimensions of "' & + & //TRIM(v_n)//'" will be returned') + ENDIF + i_w = MIN(n_w,i_s) + id_dims(1:i_w) = dim_ids(1:i_w) + ENDIF + ENDIF + IF (PRESENT(nb_atts).OR.PRESENT(cn_atts)) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,nAtts=n_w) + IF (PRESENT(nb_atts)) THEN + nb_atts = n_w + ENDIF + IF (PRESENT(cn_atts)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_atts) + DO i_w=1,i_s + cn_atts(i_w)(:) = '?' + ENDDO + IF (PRESENT(ia_start)) THEN + iws = ia_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(ia_count)) THEN + iwc = ia_count + ELSE + iwc = n_w + ENDIF + IF (iws > n_w) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqv', & + & 'The start index of requested attributes', & + & 'is greater than the number of attributes of', & + & '"'//TRIM(v_n)//'"') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqv', & + & 'The start index of requested attributes', & + & 'is invalid ( < 1 ) for', & + & '"'//TRIM(v_n)//'"') + ENDIF + IF ((iws+iwc-1) > n_w) THEN + CALL ipslerr (2,'flioinqv', & + & 'The number of requested attributes', & + & 'is greater than the number of attributes of', & + & '"'//TRIM(v_n)//'"') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqv', & + & 'The number of attributes to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first attributes of "' & + & //TRIM(v_n)//'" will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqv', & + & 'The number of requested attributes', & + & 'is invalid ( < 1 ) for', & + & '"'//TRIM(v_n)//'"') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,n_w-iws+1) + i_rc = NF90_INQ_ATTNAME(f_e, & + & i_v,i_w+iws-1,name=cn_atts(i_w)) + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqv" + ENDIF +!---------------------- +END SUBROUTINE flioinqv +!=== +SUBROUTINE fliogv_i40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_i40 +!=== +SUBROUTINE fliogv_i41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i41 +!=== +SUBROUTINE fliogv_i42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i42 +!=== +SUBROUTINE fliogv_i43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i43 +!=== +SUBROUTINE fliogv_i44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i44 +!=== +SUBROUTINE fliogv_i45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i45 +!=== +SUBROUTINE fliogv_i20 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_20=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_i20 +!=== +SUBROUTINE fliogv_i21 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_21=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i21 +!=== +SUBROUTINE fliogv_i22 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_22=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i22 +!=== +SUBROUTINE fliogv_i23 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_23=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i23 +!=== +SUBROUTINE fliogv_i24 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_24=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i24 +!=== +SUBROUTINE fliogv_i25 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_25=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i25 +!=== +!?INTEGERS of KIND 1 are not supported on all computers +!?SUBROUTINE fliogv_i10 (f_i,v_n,v_v,start) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_10=v_v,start=start) +!?!------------------------ +!?END SUBROUTINE fliogv_i10 +!?!=== +!?SUBROUTINE fliogv_i11 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_11=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i11 +!?!=== +!?SUBROUTINE fliogv_i12 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_12=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i12 +!?!=== +!?SUBROUTINE fliogv_i13 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_13=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i13 +!?!=== +!?SUBROUTINE fliogv_i14 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_14=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i14 +!?!=== +!?SUBROUTINE fliogv_i15 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_15=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i15 +!=== +SUBROUTINE fliogv_r40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_r40 +!=== +SUBROUTINE fliogv_r41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r41 +!=== +SUBROUTINE fliogv_r42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r42 +!=== +SUBROUTINE fliogv_r43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r43 +!=== +SUBROUTINE fliogv_r44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r44 +!=== +SUBROUTINE fliogv_r45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r45 +!=== +SUBROUTINE fliogv_r80 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_80=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_r80 +!=== +SUBROUTINE fliogv_r81 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_81=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r81 +!=== +SUBROUTINE fliogv_r82 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_82=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r82 +!=== +SUBROUTINE fliogv_r83 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_83=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r83 +!=== +SUBROUTINE fliogv_r84 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_84=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r84 +!=== +SUBROUTINE fliogv_r85 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_85=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r85 +!=== +SUBROUTINE flio_ugv & + & (f_i,v_n, & + & i_40,i_41,i_42,i_43,i_44,i_45, & + & i_20,i_21,i_22,i_23,i_24,i_25, & +!? & i_10,i_11,i_12,i_13,i_14,i_15, & + & r_40,r_41,r_42,r_43,r_44,r_45, & + & r_80,r_81,r_82,r_83,r_84,r_85, & + & start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(OUT),OPTIONAL :: i_40 + INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_41 + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_42 + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_43 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_44 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_45 + INTEGER(KIND=i_2),INTENT(OUT),OPTIONAL :: i_20 + INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_21 + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_22 + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_23 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_24 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_25 +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER(KIND=i_1),INTENT(OUT),OPTIONAL :: i_10 +!?INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_11 +!?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_12 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_13 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_14 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_15 + REAL(KIND=r_4),INTENT(OUT),OPTIONAL :: r_40 + REAL(KIND=r_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_41 + REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_42 + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_43 + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_44 + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_45 + REAL(KIND=r_8),INTENT(OUT),OPTIONAL :: r_80 + REAL(KIND=r_8),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_81 + REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_82 + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_83 + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_84 + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_85 + INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count +!- + INTEGER :: f_e,i_v,i_rc + CHARACTER(LEN=5) :: cvr_d +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + IF (PRESENT(i_40)) THEN; cvr_d = "I1 0D"; + ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D"; + ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D"; + ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D"; + ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D"; + ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D"; + ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D"; + ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D"; + ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D"; + ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D"; + ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D"; + ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D"; +!? ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D"; +!? ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D"; +!? ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D"; +!? ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D"; +!? ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D"; +!? ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D"; + ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D"; + ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D"; + ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D"; + ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D"; + ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D"; + ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D"; + ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D"; + ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D"; + ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D"; + ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D"; + ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D"; + ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D"; + ENDIF + WRITE(*,*) "->fliogetv ",TRIM(v_n)," ",TRIM(cvr_d) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliogetv',f_i,f_e) +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc == NF90_NOERR) THEN + IF (PRESENT(i_40)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_40,start=start) + ELSE IF (PRESENT(i_41)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_41,start=start,count=count) + ELSE IF (PRESENT(i_42)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_42,start=start,count=count) + ELSE IF (PRESENT(i_43)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_43,start=start,count=count) + ELSE IF (PRESENT(i_44)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_44,start=start,count=count) + ELSE IF (PRESENT(i_45)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_45,start=start,count=count) + ELSE IF (PRESENT(i_20)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_20,start=start) + ELSE IF (PRESENT(i_21)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_21,start=start,count=count) + ELSE IF (PRESENT(i_22)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_22,start=start,count=count) + ELSE IF (PRESENT(i_23)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_23,start=start,count=count) + ELSE IF (PRESENT(i_24)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_24,start=start,count=count) + ELSE IF (PRESENT(i_25)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_25,start=start,count=count) +!? ELSE IF (PRESENT(i_10)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_10,start=start) +!? ELSE IF (PRESENT(i_11)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_11,start=start,count=count) +!? ELSE IF (PRESENT(i_12)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_12,start=start,count=count) +!? ELSE IF (PRESENT(i_13)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_13,start=start,count=count) +!? ELSE IF (PRESENT(i_14)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_14,start=start,count=count) +!? ELSE IF (PRESENT(i_15)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_15,start=start,count=count) + ELSE IF (PRESENT(r_40)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_40,start=start) + ELSE IF (PRESENT(r_41)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_41,start=start,count=count) + ELSE IF (PRESENT(r_42)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_42,start=start,count=count) + ELSE IF (PRESENT(r_43)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_43,start=start,count=count) + ELSE IF (PRESENT(r_44)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_44,start=start,count=count) + ELSE IF (PRESENT(r_45)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_45,start=start,count=count) + ELSE IF (PRESENT(r_80)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_80,start=start) + ELSE IF (PRESENT(r_81)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_81,start=start,count=count) + ELSE IF (PRESENT(r_82)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_82,start=start,count=count) + ELSE IF (PRESENT(r_83)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_83,start=start,count=count) + ELSE IF (PRESENT(r_84)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_84,start=start,count=count) + ELSE IF (PRESENT(r_85)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_85,start=start,count=count) + ENDIF + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogetv', & + & 'Variable '//TRIM(v_n)//' not get','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + ELSE + CALL ipslerr (3,'fliogetv','Variable',TRIM(v_n),'not found') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliogetv" + ENDIF +!---------------------- +END SUBROUTINE flio_ugv +!=== +SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + LOGICAL,INTENT(OUT) :: l_ex + INTEGER,OPTIONAL,INTENT(OUT) :: a_t,a_l +!- + INTEGER :: i_rc,f_e,i_v,t_ea,l_ea +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqa ",TRIM(v_n),"-",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioinqa',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioinqa', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea) +!- + l_ex = (i_rc == NF90_NOERR) +!- + IF (l_ex) THEN + IF (PRESENT(a_t)) THEN + a_t = t_ea + ENDIF + IF (PRESENT(a_l)) THEN + a_l = l_ea + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqa" + ENDIF +!---------------------- +END SUBROUTINE flioinqa +!=== +SUBROUTINE flioga_r4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_4_0=a_v) +!--------------------------- +END SUBROUTINE flioga_r4_0d +!=== +SUBROUTINE flioga_r4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_4_1=a_v) +!-------------------------- +END SUBROUTINE flioga_r4_1d +!=== +SUBROUTINE flioga_r8_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_8_0=a_v) +!--------------------------- +END SUBROUTINE flioga_r8_0d +!=== +SUBROUTINE flioga_r8_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),DIMENSION(:),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_8_1=a_v) +!-------------------------- +END SUBROUTINE flioga_r8_1d +!=== +SUBROUTINE flioga_i4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avi_4_0=a_v) +!--------------------------- +END SUBROUTINE flioga_i4_0d +!=== +SUBROUTINE flioga_i4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avi_4_1=a_v) +!-------------------------- +END SUBROUTINE flioga_i4_1d +!=== +SUBROUTINE flioga_tx_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + CHARACTER(LEN=*),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avtx=a_v) +!--------------------------- +END SUBROUTINE flioga_tx_0d +!=== +SUBROUTINE flio_uga & + & (f_i,v_n,a_n, & + & avr_4_0,avr_4_1,avr_8_0,avr_8_1,avi_4_0,avi_4_1,avtx) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),OPTIONAL,INTENT(OUT) :: avr_4_0 + REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_4_1 + REAL(KIND=8),OPTIONAL,INTENT(OUT) :: avr_8_0 + REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_8_1 + INTEGER(KIND=4),OPTIONAL,INTENT(OUT) :: avi_4_0 + INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avi_4_1 + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: avtx +!- + INTEGER :: f_e,l_ua,i_v,t_ea,l_ea,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliogeta ",TRIM(v_n)," ",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliogeta',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogeta', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogeta', & + & 'Attribute :',TRIM(a_n),'not found') + ENDIF +!- + IF ( (.NOT.PRESENT(avtx).AND.(t_ea == NF90_CHAR)) & + & .OR.(PRESENT(avtx).AND.(t_ea /= NF90_CHAR)) ) THEN + CALL ipslerr (3,'fliogeta', & + & 'The external type of the attribute :',TRIM(a_n), & + & 'is not compatible with the type of the argument') + ENDIF +!- + IF (PRESENT(avr_4_1)) THEN + l_ua = SIZE(avr_4_1) + ELSE IF (PRESENT(avr_8_1)) THEN + l_ua = SIZE(avr_8_1) + ELSE IF (PRESENT(avi_4_1)) THEN + l_ua = SIZE(avi_4_1) + ELSE IF (PRESENT(avtx)) THEN + l_ua = LEN(avtx) + ELSE + l_ua = 1 + ENDIF +!- + IF (l_ua < l_ea) THEN + CALL ipslerr (3,'fliogeta', & + 'Insufficient size of the argument', & + & 'to receive the values of the attribute :',TRIM(a_n)) + ENDIF +!- + IF (PRESENT(avr_4_0)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_0) + ELSE IF (PRESENT(avr_4_1)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_1(1:l_ea)) + ELSE IF (PRESENT(avr_8_0)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_0) + ELSE IF (PRESENT(avr_8_1)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_1(1:l_ea)) + ELSE IF (PRESENT(avi_4_0)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_0) + ELSE IF (PRESENT(avi_4_1)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_1(1:l_ea)) + ELSE IF (PRESENT(avtx)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avtx) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliogeta" + ENDIF +!---------------------- +END SUBROUTINE flio_uga +!=== +SUBROUTINE fliorenv (f_i,v_o_n,v_n_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_o_n,v_n_n +!- + INTEGER :: f_e,i_v,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) & + & "->fliorenv ",TRIM(v_o_n),"->",TRIM(v_n_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliorenv',f_i,f_e) +!- + i_rc = NF90_INQ_VARID(f_e,v_o_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorenv', & + 'Variable :',TRIM(v_o_n),'not found') + ELSE + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_RENAME_VAR(f_e,i_v,v_n_n) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorenv', & + 'Variable :',TRIM(v_o_n),'can not be renamed') + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliorenv" + ENDIF +!---------------------- +END SUBROUTINE fliorenv +!=== +SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_o_n,a_n_n +!- + INTEGER :: f_e,i_v,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) & + & "->fliorena ",TRIM(v_n),"-",TRIM(a_o_n),"->",TRIM(a_n_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliorena',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliorena', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_o_n,attnum=i_a) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorena', & + 'Attribute :',TRIM(a_o_n),'not found') + ELSE + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_RENAME_ATT(f_e,i_v,a_o_n,a_n_n) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorena', & + 'Attribute :',TRIM(a_o_n),'can not be renamed') + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliorena" + ENDIF +!---------------------- +END SUBROUTINE fliorena +!=== +SUBROUTINE fliodela (f_i,v_n,a_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n +!- + INTEGER :: f_e,i_v,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliodela ",TRIM(v_n),"-",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliodela',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliodela', & + & 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliodela', & + & 'Attribute :',TRIM(a_n),'not found') + ELSE + IF (i_v == NF90_GLOBAL) THEN + nw_na(f_i) = nw_na(f_i)-1 + ENDIF + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_DEL_ATT(f_e,i_v,a_n) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliodela" + ENDIF +!---------------------- +END SUBROUTINE fliodela +!=== +SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i_i,f_i_o + CHARACTER(LEN=*),INTENT(IN) :: v_n_i,a_n,v_n_o +!- + INTEGER :: f_e_i,f_e_o,i_v_i,i_v_o,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliocpya - file",f_i_i,"-",TRIM(v_n_i),"-",TRIM(a_n) + WRITE(*,*) " copied to file ",f_i_o,"-",TRIM(v_n_o) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliocpya',f_i_i,f_e_i) + CALL flio_qvid ('fliocpya',f_i_o,f_e_o) +!- + IF (TRIM(v_n_i) == '?') THEN + i_v_i = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e_i,v_n_i,i_v_i) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + & 'Variable :',TRIM(v_n_i),'not found') + ENDIF + ENDIF +!- + IF (TRIM(v_n_o) == '?') THEN + i_v_o = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e_o,v_n_o,i_v_o) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + & 'Variable :',TRIM(v_n_o),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_i,i_v_i,a_n,attnum=i_a) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + 'Attribute :',TRIM(a_n),'not found') + ELSE + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_o,i_v_o,a_n,attnum=i_a) + IF ( (i_v_o == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN + nw_na(f_i_o) = nw_na(f_i_o)+1 + ENDIF + CALL flio_hdm (f_i_o,f_e_o,.TRUE.) + i_rc = NF90_COPY_ATT(f_e_i,i_v_i,a_n,f_e_o,i_v_o) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + & 'Attribute '//TRIM(a_n)//' not copied','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliocpya" + ENDIF +!---------------------- +END SUBROUTINE fliocpya +!=== +SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: c_type + LOGICAL,INTENT(OUT) :: l_ex + CHARACTER(LEN=*),INTENT(OUT) :: c_name +!- + CHARACTER(LEN=1) :: c_ax + INTEGER :: f_e,idc,ndc,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioqstc ",TRIM(c_type) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioqstc',f_i,f_e) +!- + c_ax = TRIM(c_type) + IF ( (LEN_TRIM(c_type) == 1) & + & .AND.( (c_ax == 'x').OR.(c_ax == 'y') & + & .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN + CALL flio_qax (f_i,c_ax,idc,ndc) + l_ex = (idc > 0) + IF (l_ex) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,idc,name=c_name) + ENDIF + ELSE + l_ex = .FALSE. + CALL ipslerr (2,'flioqstc', & + & 'The name of the coordinate,',TRIM(c_type),'is not valid') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioqstc" + ENDIF +!---------------------- +END SUBROUTINE flioqstc +!=== +SUBROUTINE fliosync (f_i) +!--------------------------------------------------------------------- + INTEGER,INTENT(in),OPTIONAL :: f_i +!- + INTEGER :: i_f,f_e,i_rc,i_s,i_e +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliosync" + ENDIF +!- + IF (PRESENT(f_i)) THEN + IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN + i_s = f_i + i_e = f_i + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'fliosync', & + & 'Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_fi_mx + ENDIF +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- + DO i_f=i_s,i_e + f_e = nw_id(i_f) + IF (f_e > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliosync - synchronising file number ',i_f + ENDIF + i_rc = NF90_SYNC(f_e) + ELSE IF (PRESENT(f_i)) THEN + CALL ipslerr (2,'fliosync', & + & 'Unable to synchronise the file :','probably','not opened') + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliosync" + ENDIF +!---------------------- +END SUBROUTINE fliosync +!=== +SUBROUTINE flioclo (f_i) +!--------------------------------------------------------------------- + INTEGER,INTENT(in),OPTIONAL :: f_i +!- + INTEGER :: i_f,f_e,i_rc,i_s,i_e +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioclo" + ENDIF +!- + IF (PRESENT(f_i)) THEN + IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN + i_s = f_i + i_e = f_i + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'flioclo', & + & 'Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_fi_mx + ENDIF +!- + DO i_f=i_s,i_e + f_e = nw_id(i_f) + IF (f_e > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' flioclo - closing file number ',i_f + ENDIF + i_rc = NF90_CLOSE(f_e) + nw_id(i_f) = -1 + ELSE IF (PRESENT(f_i)) THEN + CALL ipslerr (2,'flioclo', & + & 'Unable to close the file :','probably','not opened') + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioclo" + ENDIF +!--------------------- +END SUBROUTINE flioclo +!=== +SUBROUTINE fliodmpf (f_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: f_n +!- + INTEGER :: f_e,n_dims,n_vars,n_atts,i_unlm + INTEGER :: i_rc,i_n,k_n,t_ea,l_ea + INTEGER :: tmp_i + REAL :: tmp_r + INTEGER,DIMENSION(:),ALLOCATABLE :: tma_i + REAL,DIMENSION(:),ALLOCATABLE :: tma_r + CHARACTER(LEN=256) :: tmp_c + INTEGER,DIMENSION(nb_fd_mx) :: n_idim,n_ldim + INTEGER,DIMENSION(nb_ax_mx) :: n_ai + CHARACTER(LEN=NF90_MAX_NAME),DIMENSION(nb_fd_mx) :: c_ndim + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid + CHARACTER(LEN=NF90_MAX_NAME) :: c_name +!--------------------------------------------------------------------- + i_rc = NF90_OPEN(TRIM(f_n),NF90_NOWRITE,f_e) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliodmpf', & + & 'Could not open file :',TRIM(f_n), & + & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') + ENDIF +!- + WRITE (*,*) "---" + WRITE (*,*) "--- File '",TRIM(f_n),"'" + WRITE (*,*) "---" +!- + CALL flio_inf & + & (f_e,nb_dims=n_dims,nb_vars=n_vars, & + & nb_atts=n_atts,id_unlm=i_unlm, & + & nn_idm=n_idim,nn_ldm=n_ldim,cc_ndm=c_ndim,nn_aid=n_ai) +!- + WRITE (*,*) 'External model identifier : ',f_e + WRITE (*,*) 'Number of dimensions : ',n_dims + WRITE (*,*) 'Number of variables : ',n_vars + WRITE (*,*) 'ID unlimited : ',i_unlm +!- + WRITE (*,*) "---" + WRITE (*,*) 'Presumed axis dimensions identifiers :' + IF (n_ai(k_lon) > 0) THEN + WRITE (*,*) 'x axis : ',n_ai(k_lon) + ELSE + WRITE (*,*) 'x axis : NONE' + ENDIF + IF (n_ai(k_lat) > 0) THEN + WRITE (*,*) 'y axis : ',n_ai(k_lat) + ELSE + WRITE (*,*) 'y axis : NONE' + ENDIF + IF (n_ai(k_lev) > 0) THEN + WRITE (*,*) 'z axis : ',n_ai(k_lev) + ELSE + WRITE (*,*) 'z axis : NONE' + ENDIF + IF (n_ai(k_tim) > 0) THEN + WRITE (*,*) 't axis : ',n_ai(k_tim) + ELSE + WRITE (*,*) 't axis : NONE' + ENDIF +!- + WRITE (*,*) "---" + WRITE (*,*) 'Number of global attributes : ',n_atts + DO k_n=1,n_atts + i_rc = NF90_INQ_ATTNAME(f_e,NF90_GLOBAL,k_n,c_name) + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,NF90_GLOBAL,c_name, & + & xtype=t_ea,len=l_ea) + IF ( (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) & + .OR.(t_ea == NF90_INT1) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_i(l_ea)) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_i) + WRITE (*,'(" ",A," :",/,(5(1X,I10),:))') & + & TRIM(c_name),tma_i(1:l_ea) + DEALLOCATE(tma_i) + ELSE + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_i) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_i + ENDIF + ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_r(l_ea)) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_r) + WRITE (*,'(" ",A," :",/,(5(1X,1PE11.3),:))') & + & TRIM(c_name),tma_r(1:l_ea) + DEALLOCATE(tma_r) + ELSE + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_r) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_r + ENDIF + ELSE + tmp_c = '' + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_c) + WRITE(*,*) ' ',TRIM(c_name),' : "',TRIM(tmp_c),'"' + ENDIF + ENDDO +!- + DO i_n=1,nb_fd_mx + IF (n_idim(i_n) > 0) THEN + WRITE (*,*) "---" + WRITE (*,*) 'Dimension id : ',n_idim(i_n) + WRITE (*,*) 'Dimension name : ',TRIM(c_ndim(i_n)) + WRITE (*,*) 'Dimension size : ',n_ldim(i_n) + ENDIF + ENDDO +!- + DO i_n=1,n_vars + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_n, & + & name=c_name,ndims=n_dims,dimids=idimid,nAtts=n_atts) + WRITE (*,*) "---" + WRITE (*,*) "Variable name : ",TRIM(c_name) + WRITE (*,*) "Variable identifier : ",i_n + WRITE (*,*) "Number of dimensions : ",n_dims + IF (n_dims > 0) THEN + WRITE (*,*) "Dimensions ID's : ",idimid(1:n_dims) + ENDIF + WRITE (*,*) "Number of attributes : ",n_atts + DO k_n=1,n_atts + i_rc = NF90_INQ_ATTNAME(f_e,i_n,k_n,c_name) + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_n,c_name, & + & xtype=t_ea,len=l_ea) + IF ( (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) & + & .OR.(t_ea == NF90_INT1) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_i(l_ea)) + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_i) + WRITE (*,'(" ",A," :",/,(5(1X,I10),:))') & + & TRIM(c_name),tma_i(1:l_ea) + DEALLOCATE(tma_i) + ELSE + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_i) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_i + ENDIF + ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_r(l_ea)) + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_r) + WRITE (*,'(" ",A," :",/,(5(1X,1PE11.3),:))') & + & TRIM(c_name),tma_r(1:l_ea) + DEALLOCATE(tma_r) + ELSE + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_r) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_r + ENDIF + ELSE + tmp_c = '' + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_c) + WRITE(*,*) ' ',TRIM(c_name),' : "',TRIM(tmp_c),'"' + ENDIF + ENDDO + ENDDO + WRITE (*,*) "---" +!- + i_rc = NF90_CLOSE(f_e) +!---------------------- +END SUBROUTINE fliodmpf +!=== +SUBROUTINE flio_dom_set & + & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: dtnb,dnb + INTEGER,DIMENSION(:),INTENT(IN) :: did,dsg,dsl,dpf,dpl,dhs,dhe + CHARACTER(LEN=*),INTENT(IN) :: cdnm + INTEGER,INTENT(OUT) :: id_dom +!- + INTEGER :: k_w,i_w,i_s + CHARACTER(LEN=l_dns) :: cd_p,cd_w +!--------------------------------------------------------------------- + k_w = flio_dom_rid() + IF (k_w < 0) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'too many domains simultaneously defined', & + & 'please unset useless domains', & + & 'by calling flio_dom_unset') + ENDIF + id_dom = k_w +!- + d_n_t(k_w) = dtnb + d_n_c(k_w) = dnb +!- + i_s = SIZE(did) + IF (i_s > dom_max_dims) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'too many distributed dimensions', & + & 'simultaneously defined',' ') + ENDIF + d_d_n(k_w) = i_s + d_d_i(1:i_s,k_w) = did(1:i_s) +!- + i_w = SIZE(dsg) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_size_global array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_s_g(1:i_w,k_w) = dsg(1:i_w) +!- + i_w = SIZE(dsl) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_size_local array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_s_l(1:i_w,k_w) = dsl(1:i_w) +!- + i_w = SIZE(dpf) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_position_first array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_p_f(1:i_w,k_w) = dpf(1:i_w) +!- + i_w = SIZE(dpl) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_position_last array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_p_l(1:i_w,k_w) = dpl(1:i_w) +!- + i_w = SIZE(dhs) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_halo_size_start array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_h_s(1:i_w,k_w) = dhs(1:i_w) +!- + i_w = SIZE(dhe) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_halo_size_end array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_h_e(1:i_w,k_w) = dhe(1:i_w) +!- + cd_p = "unknown" + cd_w = cdnm; CALL strlowercase (cd_w) + DO i_w=1,n_dns + IF (TRIM(cd_w) == TRIM(c_dns(i_w))) THEN + cd_p = cd_w; EXIT; + ENDIF + ENDDO + IF (TRIM(cd_p) == "unknown") THEN + CALL ipslerr (3,'flio_dom_set', & + & 'DOMAIN_type "'//TRIM(cdnm)//'"', & + & 'is actually not supported', & + & 'please use one of the supported names') + ENDIF + c_d_t(k_w) = cd_p +!-------------------------- +END SUBROUTINE flio_dom_set +!=== +SUBROUTINE flio_dom_unset (id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN),OPTIONAL :: id_dom +!- + INTEGER :: i_w +!--------------------------------------------------------------------- + IF (PRESENT(id_dom)) THEN + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + IF (d_d_n(id_dom) > 0) THEN + d_d_n(id_dom) = -1 + ELSE + CALL ipslerr (2,'flio_dom_unset', & + & 'The domain is not set',' ',' ') + ENDIF + ELSE + CALL ipslerr (2,'flio_dom_unset', & + & 'Invalid file identifier',' ',' ') + ENDIF + ELSE + DO i_w=1,dom_max_nb + d_d_n(id_dom) = -1 + ENDDO + ENDIF +!---------------------------- +END SUBROUTINE flio_dom_unset +!=== +SUBROUTINE flio_dom_defset (id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: id_dom +!--------------------------------------------------------------------- + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + id_def_dom = id_dom + ELSE + CALL ipslerr (3,'flio_dom_defset', & + & 'Invalid domain identifier',' ',' ') + ENDIF +!----------------------------- +END SUBROUTINE flio_dom_defset +!=== +SUBROUTINE flio_dom_defunset () +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + id_def_dom = FLIO_DOM_NONE +!------------------------------- +END SUBROUTINE flio_dom_defunset +!=== +SUBROUTINE flio_dom_definq (id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: id_dom +!--------------------------------------------------------------------- + id_dom = id_def_dom +!----------------------------- +END SUBROUTINE flio_dom_definq +!=== +!- +!--------------------------------------------------------------------- +!- Semi-public procedures +!--------------------------------------------------------------------- +!- +!=== +SUBROUTINE flio_dom_file (f_n,id_dom) +!--------------------------------------------------------------------- +!- Update the model file name to include the ".nc" suffix and +!- the DOMAIN number on which this copy of IOIPSL runs, if needed. +!- This routine is called by IOIPSL and not by user anyway. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(INOUT) :: f_n + INTEGER,OPTIONAL,INTENT(IN) :: id_dom +!- + INTEGER :: il,iw + CHARACTER(LEN=4) :: str +!--------------------------------------------------------------------- +!- +! Add the ".nc" suffix if needed + il = LEN_TRIM(f_n) + IF (f_n(il-2:il) /= '.nc') THEN + f_n = f_n(1:il)//'.nc' + ENDIF +!- +! Add the DOMAIN identifier if needed + IF (PRESENT(id_dom)) THEN + IF (id_dom == FLIO_DOM_DEFAULT) THEN + CALL flio_dom_definq (iw) + ELSE + iw = id_dom + ENDIF + IF (iw /= FLIO_DOM_NONE) THEN + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + IF (d_d_n(iw) > 0) THEN + WRITE(str,'(I4.4)') d_n_c(iw) + il = INDEX(f_n,'.nc') + f_n = f_n(1:il-1)//'_'//str//'.nc' + ELSE + CALL ipslerr (3,'flio_dom_file', & + & 'The domain has not been defined', & + & 'please call flio_dom_set', & + & 'before calling flio_dom_file') + ENDIF + ELSE + CALL ipslerr (3,'flio_dom_file', & + & 'Invalid domain identifier',' ',' ') + ENDIF + ENDIF + ENDIF +!--------------------------- +END SUBROUTINE flio_dom_file +!=== +SUBROUTINE flio_dom_att (f_e,id_dom) +!--------------------------------------------------------------------- +!- Add the DOMAIN attributes to the NETCDF file. +!- This routine is called by IOIPSL and not by user anyway. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: f_e + INTEGER,OPTIONAL,INTENT(IN) :: id_dom +!- + INTEGER :: iw,i_rc,i_n + CHARACTER(LEN=15) :: c_ddim + INTEGER :: n_idim + CHARACTER(LEN=NF90_MAX_NAME) :: c_ndim +!--------------------------------------------------------------------- + IF (PRESENT(id_dom)) THEN + IF (id_dom == FLIO_DOM_DEFAULT) THEN + CALL flio_dom_definq (iw) + ELSE + iw = id_dom + ENDIF + IF (iw /= FLIO_DOM_NONE) THEN + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + IF (d_d_n(iw) > 0) THEN + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_number_total',d_n_t(iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_number',d_n_c(iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_dimensions_ids',d_d_i(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_size_global',d_s_g(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_size_local',d_s_l(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_position_first',d_p_f(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_position_last',d_p_l(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_halo_size_start',d_h_s(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_halo_size_end',d_h_e(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_type',TRIM(c_d_t(iw))) + i_rc = NF90_INQUIRE (f_e,nDimensions=n_idim) + DO i_n=1,n_idim + i_rc = NF90_INQUIRE_DIMENSION (f_e,i_n,name=c_ndim) + WRITE (UNIT=c_ddim,FMT='("DOMAIN_DIM_N",I3.3)') i_n + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL,c_ddim,TRIM(c_ndim)) + ENDDO + ELSE + CALL ipslerr (3,'flio_dom_att', & + & 'The domain has not been defined', & + & 'please call flio_dom_set', & + & 'before calling flio_dom_att') + ENDIF + ELSE + CALL ipslerr (3,'flio_dom_att', & + & 'Invalid domain identifier',' ',' ') + ENDIF + ENDIF + ENDIF +!-------------------------- +END SUBROUTINE flio_dom_att +!=== +!- +!--------------------------------------------------------------------- +!- Local procedures +!--------------------------------------------------------------------- +!- +!=== +INTEGER FUNCTION flio_rid() +!--------------------------------------------------------------------- +!- returns a free index in nw_id(:) +!--------------------------------------------------------------------- + INTEGER,DIMENSION(1:1) :: nfi +!- + IF (ANY(nw_id < 0)) THEN + nfi = MINLOC(nw_id,MASK=nw_id < 0) + flio_rid = nfi(1) + ELSE + flio_rid = -1 + ENDIF +!-------------------- +END FUNCTION flio_rid +!=== +INTEGER FUNCTION flio_dom_rid() +!--------------------------------------------------------------------- +!- returns a free index in d_d_n(:) +!--------------------------------------------------------------------- + INTEGER,DIMENSION(1:1) :: nd +!--------------------------------------------------------------------- + IF (ANY(d_d_n < 0)) THEN + nd = MINLOC(d_d_n,MASK=d_d_n < 0) + flio_dom_rid = nd(1) + ELSE + flio_dom_rid = -1 + ENDIF +!------------------------ +END FUNCTION flio_dom_rid +!=== +INTEGER FUNCTION flio_qid(iid) +!--------------------------------------------------------------------- +!- returns the external index associated with the internal index "iid" +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: iid +!--------------------------------------------------------------------- + IF ( (iid >= 1).AND.(iid <= nb_fi_mx) ) THEN + flio_qid = nw_id(iid) + ELSE + flio_qid = -1 + ENDIF +!-------------------- +END FUNCTION flio_qid +!=== +SUBROUTINE flio_qvid (cpg,iid,ixd) +!--------------------------------------------------------------------- +!- This subroutine, called by the procedure "cpg", +!- validates and returns the external file index "ixd" +!- associated with the internal file index "iid" +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: cpg + INTEGER,INTENT(IN) :: iid + INTEGER,INTENT(OUT) :: ixd +!- + CHARACTER(LEN=20) :: c_t +!--------------------------------------------------------------------- + ixd = flio_qid(iid) + IF (ixd < 0) THEN + WRITE (UNIT=c_t,FMT='(I15)') iid + CALL ipslerr (3,TRIM(cpg), & + & 'Invalid internal file index :',TRIM(ADJUSTL(c_t)),' ') + ENDIF +!----------------------- +END SUBROUTINE flio_qvid +!=== +SUBROUTINE flio_hdm (f_i,f_e,lk_hm) +!--------------------------------------------------------------------- +!- This subroutine handles the "define/data mode" of NETCDF. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i,f_e + LOGICAL,INTENT(IN) :: lk_hm +!- + INTEGER :: i_rc +!--------------------------------------------------------------------- + i_rc = NF90_NOERR +!- + IF ( (.NOT.lw_hm(f_i)).AND.(lk_hm) ) THEN + i_rc = NF90_REDEF(f_e) + lw_hm(f_i) = .TRUE. + ELSE IF ( (lw_hm(f_i)).AND.(.NOT.lk_hm) ) THEN + i_rc = NF90_ENDDEF(f_e) + lw_hm(f_i) = .FALSE. + ENDIF +!- + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flio_hdm', & + & 'Internal error ','in define/data mode :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF +!---------------------- +END SUBROUTINE flio_hdm +!=== +SUBROUTINE flio_inf (f_e, & + & nb_dims,nb_vars,nb_atts,id_unlm,nn_idm,nn_ldm,nn_aid,cc_ndm) +!--------------------------------------------------------------------- +!- This subroutine allows to get some information concerning +!- the model file whose the external identifier is "f_e". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_e + INTEGER,OPTIONAL,INTENT(OUT) :: nb_dims,nb_vars,nb_atts,id_unlm + INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: nn_idm,nn_ldm,nn_aid + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cc_ndm +!- + INTEGER :: nm_dims,nm_vars,nm_atts,nm_unlm,ml + INTEGER :: i_rc,kv + CHARACTER(LEN=NF90_MAX_NAME) :: f_d_n +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flio_inf" + ENDIF +!- + i_rc = NF90_INQUIRE(f_e,nDimensions=nm_dims,nVariables=nm_vars, & + & nAttributes=nm_atts,unlimitedDimId=nm_unlm) +!- + IF (PRESENT(nb_dims)) nb_dims = nm_dims; + IF (PRESENT(nb_vars)) nb_vars = nm_vars; + IF (PRESENT(nb_atts)) nb_atts = nm_atts; + IF (PRESENT(id_unlm)) id_unlm = nm_unlm; +!- + IF (PRESENT(nn_idm)) nn_idm(:) = -1; + IF (PRESENT(nn_ldm)) nn_ldm(:) = 0; + IF (PRESENT(cc_ndm)) cc_ndm(:) = ' '; + IF (PRESENT(nn_aid)) nn_aid(:) = -1; +!- + DO kv=1,nm_dims +!--- + i_rc = NF90_INQUIRE_DIMENSION(f_e,kv,name=f_d_n,len=ml) + CALL strlowercase (f_d_n) + f_d_n = ADJUSTL(f_d_n) +!--- + IF (l_dbg) THEN + WRITE(*,*) " flio_inf ",kv,ml," ",TRIM(f_d_n) + ENDIF +!--- + IF (PRESENT(nn_idm)) nn_idm(kv)=kv; + IF (PRESENT(nn_ldm)) nn_ldm(kv)=ml; + IF (PRESENT(cc_ndm)) cc_ndm(kv)=TRIM(f_d_n); +!--- + IF ( (INDEX(f_d_n,'x') == 1) & + & .OR.(INDEX(f_d_n,'lon') == 1) ) THEN + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_lon) < 0) THEN + nn_aid(k_lon)=kv; + ENDIF + ENDIF + ELSE IF ( (INDEX(f_d_n,'y') == 1) & + & .OR.(INDEX(f_d_n,'lat') == 1) ) THEN + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_lat) < 0) THEN + nn_aid(k_lat)=kv; + ENDIF + ENDIF + ELSE IF ( (INDEX(f_d_n,'z') == 1) & + & .OR.(INDEX(f_d_n,'lev') == 1) & + & .OR.(INDEX(f_d_n,'plev') == 1) & + & .OR.(INDEX(f_d_n,'depth') == 1) ) THEN + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_lev) < 0) THEN + nn_aid(k_lev)=kv; + ENDIF + ENDIF + ELSE IF ( (TRIM(f_d_n) == 't') & + & .OR.(TRIM(f_d_n) == 'time') & + & .OR.(INDEX(f_d_n,'tstep') == 1) & + & .OR.(INDEX(f_d_n,'time_counter') == 1) ) THEN +!---- For the time we certainly need to allow for other names + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_tim) < 0) THEN + nn_aid(k_tim)=kv; + ENDIF + ENDIF + ENDIF +!--- + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flio_inf" + ENDIF +!---------------------- +END SUBROUTINE flio_inf +!=== +SUBROUTINE flio_qax (f_i,axtype,i_v,nbd) +!--------------------------------------------------------------------- +!- This subroutine explores the file in order to find +!- an axis (x/y/z/t) according to a number of rules +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: f_i,i_v,nbd + CHARACTER(LEN=*) :: axtype +!- + INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb + CHARACTER(LEN=1) :: c_ax + CHARACTER(LEN=18) :: c_sn + CHARACTER(LEN=15),DIMENSION(10) :: c_r + CHARACTER(LEN=40) :: c_t1,c_t2 +!--------------------------------------------------------------------- + i_v = -1; nbd = -1; +!--- +!- Keep the name of the axis +!--- + c_ax = TRIM(axtype) +!- +! Validate axis type +!- + IF ( (LEN_TRIM(axtype) == 1) & + & .AND.( (c_ax == 'x').OR.(c_ax == 'y') & + & .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN +!--- +!-- Define the maximum number of dimensions for the coordinate +!--- + SELECT CASE (c_ax) + CASE('x') + l_d = 2 + c_sn = 'longitude' + CASE('y') + l_d = 2 + c_sn = 'latitude' + CASE('z') + l_d = 1 + c_sn = 'model_level_number' + CASE('t') + l_d = 1 + c_sn = 'time' + END SELECT +!--- +!-- Rule 1 : we look for a variable with one dimension +!-- and which has the same name as its dimension (NUG) +!--- + IF (i_v < 0) THEN + SELECT CASE (c_ax) + CASE('x') + k = nw_ai(k_lon,f_i) + CASE('y') + k = nw_ai(k_lat,f_i) + CASE('z') + k = nw_ai(k_lev,f_i) + CASE('t') + k = nw_ai(k_tim,f_i) + END SELECT + IF ( (k >= 1).AND.(k <= nb_ax_mx) ) THEN + dimnb = nw_di(k,f_i) + ELSE + dimnb = -1 + ENDIF +!----- + i_rc = NF90_INQUIRE_DIMENSION(nw_id(f_i),dimnb,name=c_t1) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + L_R1: DO kv=1,nw_nv(f_i) + i_rc = NF90_INQUIRE_VARIABLE & + & (nw_id(f_i),kv,name=c_t2,ndims=n_d) + IF (n_d == 1) THEN + CALL strlowercase (c_t2) + IF (TRIM(c_t1) == TRIM(c_t2)) THEN + i_v = kv; nbd = n_d; + EXIT L_R1 + ENDIF + ENDIF + ENDDO L_R1 + ENDIF + ENDIF +!--- +!-- Rule 2 : we look for a correct "axis" attribute (CF) +!--- + IF (i_v < 0) THEN + L_R2: DO kv=1,nw_nv(f_i) + i_rc = NF90_GET_ATT(nw_id(f_i),kv,'axis',c_t1) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + IF (TRIM(c_t1) == c_ax) THEN + i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d) + IF (n_d <= l_d) THEN + i_v = kv; nbd = n_d; + EXIT L_R2 + ENDIF + ENDIF + ENDIF + ENDDO L_R2 + ENDIF +!--- +!-- Rule 3 : we look for a correct "standard_name" attribute (CF) +!--- + IF (i_v < 0) THEN + L_R3: DO kv=1,nw_nv(f_i) + i_rc = NF90_GET_ATT(nw_id(f_i),kv,'standard_name',c_t1) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + IF (TRIM(c_t1) == TRIM(c_sn)) THEN + i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d) + IF (n_d <= l_d) THEN + i_v = kv; nbd = n_d; + EXIT L_R3 + ENDIF + ENDIF + ENDIF + ENDDO L_R3 + ENDIF +!--- +!-- Rule 4 : we look for a specific name (IOIPSL) +!--- + IF (i_v < 0) THEN + SELECT CASE (c_ax) + CASE('x') + n_r = 3 + c_r(1)='nav_lon'; c_r(2)='lon'; c_r(3)='longitude'; + CASE('y') + n_r = 3 + c_r(1)='nav_lat'; c_r(2)='lat'; c_r(3)='latitude'; + CASE('z') + n_r = 8 + c_r(1)='depth'; c_r(2)='deptht'; c_r(3)='height'; + c_r(4)='level'; c_r(5)='lev'; c_r(6)='plev'; + c_r(7)='sigma_level'; c_r(8)='layer'; + CASE('t') + n_r = 3 + c_r(1)='time'; c_r(2)='tstep'; c_r(3)='timesteps'; + END SELECT +!----- + L_R4: DO kv=1,nw_nv(f_i) + i_rc = NF90_INQUIRE_VARIABLE & + & (nw_id(f_i),kv,name=c_t1,ndims=n_d) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + IF (n_d <= l_d) THEN + DO k=1,n_r + IF (TRIM(c_t1) == TRIM(c_r(k))) THEN + i_v = kv; nbd = n_d; + EXIT L_R4 + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO L_R4 + ENDIF +!--- + ENDIF +!---------------------- +END SUBROUTINE flio_qax +!- +!=== +!- +END MODULE fliocom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/95/9507013e06a4a1d7270f7142358c106288ab37f7.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/95/9507013e06a4a1d7270f7142358c106288ab37f7.svn-base new file mode 100644 index 0000000..30dc80e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/95/9507013e06a4a1d7270f7142358c106288ab37f7.svn-base @@ -0,0 +1,393 @@ +MODULE declare +! -*- Mode: f90 -*- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!- +! f90 -L/usr/local/lib -lnetcdf -align dcommons -g +! -ladebug -check format -check bounds +! -check output_conversion -fpe1 +! -I/usr/local/include -free -arch host -tune host +! -warn declarations -warn argument_checking +! ncunderflow.f -o ncunderflow +! +! ifc -FR -cl,ncunderflow.pcl -o ncunderflow ncunderflow.f +! -L/usr/local/install/netcdf/lib/libnetcdf.a -lPEPCF90 +! + IMPLICIT NONE + INTEGER, PARAMETER :: r4 = 4, r8 = 8, i4 = 4, i8 = 8 + INTEGER, PARAMETER :: il = KIND(1) + LOGICAL :: ldebug = .FALSE. + INTEGER (kind = il) :: nout = 0, nerr = 0 ! Standard output, standard error + CHARACTER (LEN=4), PARAMETER :: cerror = 'VOID' +END MODULE declare +!! +MODULE mod_nfdiag +CONTAINS + SUBROUTINE nfdiag ( kios, clmess, lcd) + !! + !! Imprime un message d'erreur NetCDF + !! + USE declare + IMPLICIT NONE + INCLUDE 'netcdf.inc' + !! + INTEGER (kind=i4), INTENT (in) :: kios + CHARACTER (len = *), INTENT (in) :: clmess + LOGICAL, INTENT (in), OPTIONAL :: lcd + CHARACTER (len = 80) :: clt + LOGICAL :: ld + !! + IF ( PRESENT ( lcd)) THEN + ld = lcd + ELSE + ld = ldebug + ENDIF + !! + clt = TRIM ( NF_STRERROR ( kios) ) + !! + IF ( ld ) THEN + IF ( kios == NF_NOERR ) THEN + WRITE ( unit = nout, fmt = * ) "OK : ", TRIM (clmess) + ELSE + WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios + IF ( .NOT. ld ) STOP + END IF + ELSE + IF ( kios /= NF_NOERR ) THEN + WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios + STOP + END IF + ENDIF + !! + RETURN + !! + END SUBROUTINE nfdiag + !! +END MODULE mod_nfdiag + +MODULE mod_lec +CONTAINS + !! + SUBROUTINE lec (chaine, cval, c_c) + !! + USE declare + IMPLICIT NONE + !! + CHARACTER (len = *), INTENT ( inout) :: chaine + CHARACTER (len = *), INTENT ( inout) :: cval + CHARACTER (len=*), OPTIONAL :: c_c + INTEGER (kind = il) :: ji, ji1, ji2, ji3, jl, jb + INTEGER (kind = i4) :: index + !! + !! Read character string up to ':' or ',', or in c_c if present + !! Returns the real before the character (xerror if not available) + !! Reduce the string + !! + jl = LEN (chaine) ; jb = LEN_TRIM (chaine) + IF ( ldebug) WRITE ( nout, *) 'Lec : jl, jb ', jl, jb + IF ( jb == 0 ) THEN + cval = cerror + ELSE + ji1 = INDEX (chaine, ':') ; ji2 = INDEX (chaine, ',') + IF ( PRESENT (c_c)) THEN + ji3 = INDEX (chaine, c_c) ; ji = MAX (ji1, ji2, ji3) + ELSE + ji = MAX (ji1, ji2) + ENDIF + IF ( ji == 0 ) THEN + READ ( chaine (1:jb) , fmt = * ) cval + chaine (1:jl-jb) = chaine (jb+1:jl) + ELSE IF ( ji == 1 ) THEN + cval = cerror + chaine (1:jl-1) = chaine (2:jl) + ELSE + cval = chaine (1:ji-1) + chaine (1:jl-ji) = chaine (ji+1:jl ) + END IF + END IF + !! + END SUBROUTINE lec +END MODULE mod_lec + +PROGRAM ncunderflow + + ! Ce programme ouvre un fichier de donnees au format netcdf + ! et met a zero toutes les valeurs trop petites pour etre + ! representees par un reel sur 4 octets au format IEEE + ! + ! Revision 2.0 2004/04/05 14:47:50 adm + ! JB+MAF+AC: switch to IOIPSL 2.0 (1) + ! + ! Revision 1.1 2003/04/09 15:21:56 adm + ! add ncunderflow in IOIPSL + ! and modify AA_make to take it into account + ! SD + MAF + ! + ! Revision 1.1 2001/02/07 14:36:07 jypeter + ! J-Y Peterschmitt / LMCE / 07/02/2001 + ! Initial revision + ! + USE declare + USE mod_nfdiag + USE mod_lec + IMPLICIT NONE + + INCLUDE 'netcdf.inc' + + INTEGER (kind=il), EXTERNAL :: iargc + + ! Nombre maximal de dimensions : 6 + + INTEGER (kind=il), PARAMETER :: jpmaxdim = 6, jpmaxvar = 1024 + + CHARACTER (len = 128) :: clnomprog, clnomfic + CHARACTER (len = 1024) :: clistvar, clecline + CHARACTER (len = 128), DIMENSION(jpmaxdim) :: clnomdim + CHARACTER (len = 128), DIMENSION(jpmaxvar) :: clvarcmd, clvarfic, clvar ! Nom des variables dans le fichier est sur la ligne de commande. + LOGICAL :: lrever = .FALSE. ! Si .true., on traite toutes les variables sauf celle de la ligne de commande + LOGICAL :: lnocoord = .FALSE. ! Si .truee., on exclu les variables coordonn�es + LOGICAL :: lverbose = .TRUE. + + INTEGER (kind=il) :: incid, ircode, ivarid, ivartype, inbdim, inbatt + INTEGER (kind=il) :: nvarcmd, nvarfic, nvar, nfile, jvarcmd, jvarfic, jvar, jfile, ierr + INTEGER (kind=il) :: ji, jdim3, jdim4, jdim5, jdim6, j1, j2, j3, jarg, ncumul + INTEGER (kind=il), DIMENSION(jpmaxdim) :: idimid, idimsize, istart, icount + REAL (kind=r4), DIMENSION(:,:), ALLOCATABLE :: zdatacorr + REAL (kind=r8), DIMENSION(:,:), ALLOCATABLE :: zdata + REAL (kind=r4) :: reps = TINY (1.0_r4) * 10.0_r4 + LOGICAL :: lok + + ! Verification du nombre de parametres + IF(iargc() .LT. 2) THEN + CALL usage + STOP + ENDIF + + ! Aide + jarg = 1 + Lab1: DO WHILE ( jarg <= 3 ) + IF (ldebug) WRITE(nout,*) 'lecture ligne commande ', jarg + CALL getarg (jarg,clecline) + IF ( clecline(1:1) /= '-' ) EXIT Lab1 + IF ( clecline(1:2) == '-h' .OR. clecline(1:2) == '-?' ) THEN + CALL usage + STOP + ELSE IF ( clecline(1:2) == '-x' ) THEN + lrever = .TRUE. + ELSE IF ( clecline(1:2) == '-d' ) THEN + ldebug = .TRUE. + ELSE IF ( clecline(1:2) == '-V' ) THEN + lverbose = .FALSE. + ELSE IF ( clecline(1:2) == '-v' ) THEN + jarg = jarg + 1 + ! Recuperation des noms de variables + IF (ldebug) WRITE(nout,*) 'lecture liste vriables ', jarg + CALL getarg (jarg,clistvar) + clistvar = TRIM(ADJUSTL(clistvar)) + jvarcmd = 0 ; nvarcmd = 0 + SeekVar: DO WHILE ( .TRUE. ) + CALL lec ( clistvar, clvarcmd(jvarcmd+1)(:) ) + IF ( TRIM(clvarcmd(jvarcmd+1)(:)) == cerror ) EXIT SeekVar + jvarcmd = jvarcmd + 1 + nvarcmd = jvarcmd + IF (ldebug) WRITE(nout,*) 'affecte variable ', jvarcmd, TRIM(clvarcmd(jvarcmd)) + END DO SeekVar + ENDIF + jarg = jarg + 1 + END DO Lab1 + + ! Boucle sur les fichiers + FileLoop: DO jfile = jarg, iargc() + + ! Recuperation du nom du fichier a traiter + CALL getarg ( jfile, clnomfic) + + ! Ouverture du fichier + CALL nfdiag ( NF_OPEN ( TRIM(clnomfic), NF_WRITE, incid ), "Opening " // TRIM(clnomfic) ) + WRITE (nout,*) TRIM(clnomfic) + + ! Recuparation de la liste des variables du fichier + nvarfic = 0 + DO jvarfic = 1, jpmaxvar + j3 = NF_INQ_VAR ( incid, jvarfic, clvarfic(jvarfic)(:), ivartype, inbdim, idimid, inbatt) + IF ( j3 /= NF_NOERR ) EXIT + nvarfic = jvarfic + END DO + + ! Liste des variables a traiter + IF ( lrever ) THEN + IF ( nvarcmd == 0) THEN + clvar = clvarfic + nvar = nvarfic + ELSE + jvar = 0 + DO jvarfic = 1, nvarfic + lok = .TRUE. + DO jvarcmd = 1, nvarcmd + IF ( TRIM(clvarfic(jvarfic)(:)) == TRIM(clvarcmd(jvarcmd)(:)) ) THEN + lok = .FALSE. + END IF + END DO + IF ( lok) THEN + jvar = jvar + 1 + clvar(jvar) = clvarfic(jvarfic) + END IF + END DO + nvar = jvar + END IF + ELSE + clvar = clvarcmd + nvar = nvarcmd + END IF + + ncumul = 0 + VarLoop: DO jvar = 1, nvar + + IF (lverbose) & + & WRITE(nout, FMT='("Correction de ", A, " dans ", A, " : ", $)') TRIM(clvar(jvar)(:)), TRIM(clnomfic) + + ! Passage de netcdf en mode 'erreurs non fatales' + ! CALL ncpopt(NCVERBOS) + ! En fait, on reste dans le mode par defaut, dans lequel une erreur + ! netcdf cause un arret du programme. Du coup, il n'est pas + ! necessaire de tester la valeur de la variable ircode + ! ATTENTION! Si jamais on veut arreter le programme a cause d'une + ! erreur ne provenant pas de netcdf, il faut penser a fermer + ! manuellement le fichier avec un appel a ncclos + + ! Recuperation de l'identificateur de la variable + CALL nfdiag ( NF_INQ_VARID ( incid, TRIM(clvar(jvar)(:)), ivarid), "Get var id " // TRIM(clvar(jvar)(:))) + + ivartype = 0 ; idimid = 0 ; inbdim = 0 ; inbatt = 0 + ! Recuperation du nombre de dimensions de la variable + CALL nfdiag ( NF_INQ_VAR ( incid, ivarid, clvar(jvar)(:), ivartype, inbdim, idimid, inbatt), & + & "Get var info " // TRIM(clvar(jvar)(:))) + + IF(inbdim .GT. jpmaxdim) THEN + WRITE(nout,*) + WRITE(nout, *) 'La variable ', TRIM(clvar(jvar)(:)), ' a trop de dimensions' + CALL nfdiag ( NF_CLOSE (incid), "Closing file") + STOP + ENDIF + + ! Recuperation des dimensions effectives + idimsize(3:jpmaxdim) = 1 ! Au cas ou la variable n'ait que + ! 2 ou 3 dims, on initialise ces valeurs + ! qui serviront dans le controle des boucles + ! et qui auraient une valeur indefinie sinon + DO ji = 1, inbdim + CALL nfdiag ( NF_INQ_DIM ( incid, idimid(ji), clnomdim(ji), idimsize(ji)), "NF_INQ_DIM") + IF (lverbose) WRITE(nout, '(A,A,A,I3,$)') ' ', TRIM(clnomdim(ji)), ' = ', idimsize(ji) + IF ( idimsize(ji) == 0 ) THEN + WRITE(nout, '(A,A,A,A,I3)') TRIM(clvar(jvar)(:)), ', ', TRIM(clnomdim(ji)), ' = ', idimsize(ji) + CYCLE VarLoop + END IF + ENDDO + IF (lverbose) WRITE(nout,*) + idimsize = MAX ( idimsize, 1) + ncumul = ncumul + 1 + + ! Determination du type de la variable, en fonction du nom de + ! la premiere dimension +!$$$ IF(INDEX(TRIM(clnomdim(1)),'ongitude') .NE. 0) THEN +!$$$ ! var de type map ou 3d +!$$$ write(nout, *) ' --> MAP/3D' +!$$$ ELSE IF(INDEX(TRIM(clnomdim(1)),'atitude') .NE. 0) THEN +!$$$ ! var de type xsec +!$$$ write(nout, *) ' --> XSEC' +!$$$ ELSE +!$$$ WRITE(nout, *) +!$$$ WRITE(nout, *) 'Bizarre, la premiere dimension n''est ni "longitude" ni "latitude"' +!$$$ CALL ncclos(incid, ircode) +!$$$ STOP +!$$$ ENDIF + + ! Reservation de memoire pour charger et traiter + ! une grille idimsize(1)*idimsize(2) de la variable + ALLOCATE(zdata(idimsize(1), idimsize(2)), stat=ierr) + IF(ierr .NE. 0) THEN + WRITE(nout, *) 'Erreur d''allocation memoire pour zdata' + CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE") + STOP + ENDIF + ALLOCATE(zdatacorr(idimsize(1), idimsize(2)), stat=ierr) + IF(ierr .NE. 0) THEN + WRITE(nout, *) 'Erreur d''allocation memoire pour zdatacorr' + CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE") + STOP + ENDIF + + ! Parametrisation de la partie de la variable a charger en memoire + ! (une 'grille' que l'on lira autant de fois qu'il y a de niveaux et + ! de pas de temps) + ! Rappel : seuls les elements 1..inbdim des tableaux sont + ! significatifs et utiles + + icount = 0 + + DO jdim6 = 1, idimsize(6) + DO jdim5 = 1, idimsize(5) + DO jdim4 = 1, idimsize(4) + DO jdim3 = 1, idimsize(3) + istart = (/ 1 , 1 , jdim3, jdim4, jdim5, jdim6 /) + icount = (/ idimsize(1), idimsize(2), 1 , 1 , 1 , 1 /) + + ! Chargement d'une 'grille' de donnees, en real*8 + CALL nfdiag ( NF_GET_VARA_DOUBLE(incid, ivarid, istart(1:inbdim), icount(1:inbdim), zdata), & + & "NF_GET_VARA_DOUBLE") + ! Mise a zero de toutes les valeurs trop petites pour etre + ! representees par un reel sur 4 octets au format IEEE. + ! Le truc est de faire une operation nulle (addition de 0) + ! sur des donnees qui posent problemes, EN AYANT COMPILE LE PROG + ! AVEC l'OPTION "-fpe1". Dans ce cas, les valeurs trop petites + ! sont remplacees par zero (0.0) et le programme continue, + ! au lieu de planter. + ! Il est possible de faire afficher le nb de valeurs qui ont pose + ! un pb en utilisant en plus l'option "-check underflow" + zdata = zdata + 0.0_r8 + zdatacorr = REAL(zdata, KIND=r4) + WHERE ( ABS (zdatacorr) < reps) zdatacorr = 0.0_r4 + + ! Sauvegarde de la grille corrigee dans le fichier + ! (a la place de la grille initiale), en real*4 + CALL nfdiag ( NF_PUT_VARA_REAL(incid, ivarid, istart, icount, zdatacorr), "NF_PUT_VARA_REAL" ) + + END DO + END DO + END DO + END DO + + DEALLOCATE ( zdata) + DEALLOCATE ( zdatacorr) + + END DO VarLoop + + WRITE (nout,*) 'ncunderflow, nombre de variables corrigees : ', ncumul + + ! Fermeture du fichier + CALL nfdiag ( NF_CLOSE (incid), "Closing" ) + + END DO FileLoop + +CONTAINS + SUBROUTINE usage + IMPLICIT NONE + CALL getarg (0, clnomprog) + + WRITE(nout, FMT='("Command : ", A)') TRIM(clnomprog) + WRITE(nout, FMT='("Removes underflows in NetCDF files") ') + WRITE(nout, FMT='("Usage : ", A, " [-x] [-V] [-d] -v nomvar[,nomvar] nomfic [nomfic]")' ) TRIM(clnomprog) + WRITE(nout, FMT='("Options : ")' ) + WRITE(nout, FMT='(" -V : mode verbose off. Default is verbose on.")' ) + WRITE(nout, FMT='(" -d : debug mode on. Default is debug off.")' ) + WRITE(nout, FMT='(" -v : gives list of variables to be corrected, separated by a coma.")' ) + WRITE(nout, FMT='(" -x : reverses meaning of -v : given variable are not corrected")' ) + WRITE(nout, FMT='(" if -x is given, and not -v, all variables are corrected.")' ) + + + STOP + END SUBROUTINE usage + +END PROGRAM ncunderflow diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/98/987c053460844ac5ce64c4865202e3ca44bfcc8b.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/98/987c053460844ac5ce64c4865202e3ca44bfcc8b.svn-base new file mode 100644 index 0000000..77ec283 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/98/987c053460844ac5ce64c4865202e3ca44bfcc8b.svn-base @@ -0,0 +1,1784 @@ +PROGRAM flio_rbld +! +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!!-------------------------------------------------------------------- +!! PROGRAM flio_rbld +!! +!! PURPOSE : +!! Recombine the files of MPI version of IOIPSL +!! along several dimensions. +!! +!! CALLING SEQUENCE : +!! +!! "flio_rbld" is usually invoked by the script "rebuild" +!! +!! rebuild -h +!! +!! rebuild [-v lev] [-f] -o outfile infile[1] ... infile[n] +!! +!! INPUT for "rebuild" : +!! +!! -h : help +!! -v lev : verbosity level +!! -f : force executing mode +!! -o outfile : name of the recombined file. +!! infiles : names of the files that must be recombined. +!! +!! INPUT for "flio_rbld" : +!! +!! (I) i_v_lev : verbosity level +!! (C) c_force : executing mode (noforce/force) +!! (I) f_nb : total number of files +!! (C) f_nm(:) : names of the files (input_files output_file) +!! +!! +!! ASSOCIATED MODULES : +!! IOIPSL(fliocom) +!! +!! RESTRICTIONS : +!! +!! Cases for character are not coded. +!! +!! Cases for netCDF variables such as array with more +!! than 5 dimensions are not coded. +!! +!! Input files must have the following global attributes : +!! +!! "DOMAIN_number_total" +!! "DOMAIN_number" +!! "DOMAIN_dimensions_ids" +!! "DOMAIN_size_global" +!! "DOMAIN_size_local" +!! "DOMAIN_position_first" +!! "DOMAIN_position_last" +!! "DOMAIN_halo_size_start" +!! "DOMAIN_halo_size_end" +!! "DOMAIN_type" +!! +!! NetCDF files must be smaller than 2 Gb. +!! +!! Character variables should have less than 257 letters +!! +!! EXAMPLE : +!! +!! rebuild -v -o sst.nc sst_[0-9][0-9][0-9][0-9].nc +!! +!! MODIFICATION HISTORY : +!! Sebastien Masson (smasson@jamstec.go.jp) March 2004 +!! Jacques Bellier (Jacques.Bellier@cea.fr) June 2005 +!!-------------------------------------------------------------------- + USE IOIPSL + USE defprec +!- + IMPLICIT NONE +!- +! Character length + INTEGER,PARAMETER :: chlen=256 +!- +! DO loops and test related variables + INTEGER :: i,ia,id,iv,iw,i_i,i_n + INTEGER :: ik,itmin,itmax,it1,it2,it + LOGICAL :: l_force,l_uld +!- +! Input arguments related variables + INTEGER :: i_v_lev + CHARACTER(LEN=15) :: c_force + INTEGER :: f_nb,f_nb_in + CHARACTER(LEN=chlen),DIMENSION(:),ALLOCATABLE :: f_nm +!- +! Domains related variables + INTEGER :: d_n_t,i_ntd + INTEGER,DIMENSION(:),ALLOCATABLE :: dom_att,d_d_i,d_s_g + INTEGER,DIMENSION(:,:),ALLOCATABLE :: d_s_l,d_p_f,d_p_l,d_h_s,d_h_e + LOGICAL :: l_cgd,l_cof,l_col,l_o_f,l_o_m,l_o_l + CHARACTER(LEN=chlen) :: c_d_n +!- +! Model files related variables + LOGICAL :: l_ocf + INTEGER,DIMENSION(:),ALLOCATABLE :: f_a_id + INTEGER :: f_id_i1,f_id_i,f_id_o + INTEGER :: f_d_nb,f_v_nb,f_a_nb,f_d_ul + INTEGER :: v_a_nb,a_type + CHARACTER(LEN=chlen),DIMENSION(:),ALLOCATABLE :: & +& f_d_nm,f_v_nm,f_a_nm,v_a_nm + CHARACTER(LEN=chlen) :: f_u_nm + INTEGER,DIMENSION(:),ALLOCATABLE :: v_d_nb,v_d_ul,v_type + INTEGER,DIMENSION(:,:),ALLOCATABLE :: v_d_i + INTEGER,DIMENSION(:),ALLOCATABLE :: f_d_i,f_d_l + INTEGER :: a_l + INTEGER,DIMENSION(flio_max_var_dims) :: d_i,ib,ie + INTEGER,DIMENSION(:),ALLOCATABLE :: & + & io_i,io_n,ia_sf,io_sf,io_cf,ia_sm,io_sm,io_cm,ia_sl,io_sl,io_cl + LOGICAL :: l_ex + CHARACTER(LEN=chlen) :: c_wn1,c_wn2 +!- +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER(KIND=i_1) :: i1_0d +!?INTEGER(KIND=i_1),DIMENSION(:),ALLOCATABLE :: i1_1d +!?INTEGER(KIND=i_1),DIMENSION(:,:),ALLOCATABLE :: i1_2d +!?INTEGER(KIND=i_1),DIMENSION(:,:,:),ALLOCATABLE :: i1_3d +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),ALLOCATABLE :: i1_4d +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i1_5d + INTEGER(KIND=i_2) :: i2_0d + INTEGER(KIND=i_2),DIMENSION(:),ALLOCATABLE :: i2_1d + INTEGER(KIND=i_2),DIMENSION(:,:),ALLOCATABLE :: i2_2d + INTEGER(KIND=i_2),DIMENSION(:,:,:),ALLOCATABLE :: i2_3d + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),ALLOCATABLE :: i2_4d + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i2_5d + INTEGER(KIND=i_4) :: i4_0d + INTEGER(KIND=i_4),DIMENSION(:),ALLOCATABLE :: i4_1d + INTEGER(KIND=i_4),DIMENSION(:,:),ALLOCATABLE :: i4_2d + INTEGER(KIND=i_4),DIMENSION(:,:,:),ALLOCATABLE :: i4_3d + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),ALLOCATABLE :: i4_4d + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i4_5d + REAL(KIND=r_4) :: r4_0d + REAL(KIND=r_4),DIMENSION(:),ALLOCATABLE :: r4_1d + REAL(KIND=r_4),DIMENSION(:,:),ALLOCATABLE :: r4_2d + REAL(KIND=r_4),DIMENSION(:,:,:),ALLOCATABLE :: r4_3d + REAL(KIND=r_4),DIMENSION(:,:,:,:),ALLOCATABLE :: r4_4d + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),ALLOCATABLE :: r4_5d + REAL(KIND=r_8) :: r8_0d + REAL(KIND=r_8),DIMENSION(:),ALLOCATABLE :: r8_1d + REAL(KIND=r_8),DIMENSION(:,:),ALLOCATABLE :: r8_2d + REAL(KIND=r_8),DIMENSION(:,:,:),ALLOCATABLE :: r8_3d + REAL(KIND=r_8),DIMENSION(:,:,:,:),ALLOCATABLE :: r8_4d + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),ALLOCATABLE :: r8_5d +!- +! elapsed and cpu time computation variables + INTEGER :: nb_cc_ini,nb_cc_end,nb_cc_sec,nb_cc_max + REAL :: t_cpu_ini,t_cpu_end +!--------------------------------------------------------------------- +!- +!------------------- +! INPUT arguments +!------------------- +!- +! Retrieve the verbosity level + READ (UNIT=*,FMT=*) i_v_lev +!- +! Retrieve the executing mode + READ (UNIT=*,FMT='(A)') c_force + l_force = (TRIM(c_force) == 'force') +!- +! Retrieve the number of arguments + READ (UNIT=*,FMT=*) f_nb + f_nb_in = f_nb-1 +!- +! Retrieve the file names + ALLOCATE(f_nm(f_nb)) + DO iw=1,f_nb + READ (UNIT=*,FMT='(A)') f_nm(iw) + ENDDO +!- +! Allocate and initialize the array of file access identifiers + ALLOCATE(f_a_id(f_nb_in)); f_a_id(:) = -1; +!- + IF (i_v_lev >= 1) THEN + WRITE (UNIT=*,FMT='("")') + WRITE (UNIT=*,FMT='(" verbosity level : ",I4)') i_v_lev + WRITE (UNIT=*,FMT='(" executing mode : ",A)') TRIM(c_force) + WRITE (UNIT=*,FMT='(" number of args : ",I4)') f_nb + WRITE (UNIT=*,FMT='(" Input files :")') + DO iw=1,f_nb_in + WRITE (*,'(" ",A)') TRIM(f_nm(iw)) + ENDDO + WRITE (UNIT=*,FMT='(" Output file :")') + WRITE (*,'(" ",A)') TRIM(f_nm(f_nb)) +!-- time initializations + CALL system_clock & + & (count=nb_cc_ini,count_rate=nb_cc_sec,count_max=nb_cc_max) + CALL cpu_time (t_cpu_ini) + ENDIF +!- +!--------------------------------------------------- +! Retrieve basic informations from the first file +!--------------------------------------------------- +!- +! Open the first file + CALL flrb_of (1,f_id_i) +!- +! Get the attribute "DOMAIN_number_total" + CALL fliogeta (f_id_i,"?","DOMAIN_number_total",d_n_t) +!- +! Validate the number of input files : +! should be equal to the total number +! of domains used in the simulation + IF (d_n_t /= f_nb_in) THEN + IF (l_force) THEN + iw = 2 + ELSE + iw = 3 + DEALLOCATE(f_nm,f_a_id) + CALL flrb_cf (1,.TRUE.) + ENDIF + CALL ipslerr (iw,"flio_rbld", & + & "The number of input files", & + & "is not equal to the number of DOMAINS"," ") + ENDIF +!- +! Retrieve the basic characteristics of the first input file + CALL flioinqf & + & (f_id_i,nb_dim=f_d_nb,nb_var=f_v_nb,nb_gat=f_a_nb,id_uld=f_d_ul) +!- +! Build the list of the names of the +! dimensions/variables/global_attributes and retrieve +! the unlimited_dimension name from the first input file + ALLOCATE(f_d_nm(f_d_nb),f_v_nm(f_v_nb),f_a_nm(f_a_nb)) + CALL flioinqn (f_id_i,cn_dim=f_d_nm,cn_var=f_v_nm, & + & cn_gat=f_a_nm,cn_uld=f_u_nm) +!- +! Build the list of the dimensions identifiers and lengths + ALLOCATE(f_d_i(f_d_nb),f_d_l(f_d_nb)) + CALL flioinqf (f_id_i,id_dim=f_d_i,ln_dim=f_d_l) +!- +! Close the file + CALL flrb_cf (1,.FALSE.) +!- +! Check if the number of needed files is greater than +! the maximum number of simultaneously opened files. +! In that case, open and close model files for each reading, +! otherwise keep the "flio" identifiers of the opened files. + l_ocf = (f_nb > flio_max_files) +!- +!---------------------------------------------------- +! Retrieve domain informations for each input file +!---------------------------------------------------- +!- + DO iw=1,f_nb_in +!--- + CALL flrb_of (iw,f_id_i) +!--- + IF (iw > 1) THEN + c_wn1 = "DOMAIN_number_total" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),i_ntd) + IF (i_ntd /= d_n_t) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF + ENDIF +!--- + c_wn1 = "DOMAIN_dimensions_ids" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + IF (ANY(dom_att(:) == f_d_ul)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "contains the unlimited dimension") + ENDIF + ALLOCATE (d_d_i(a_l)) + d_d_i(:) = dom_att(:) + ELSEIF (SIZE(dom_att) /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ELSEIF (ANY(dom_att(:) /= d_d_i(:))) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + DEALLOCATE(dom_att) + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_size_global" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_s_g(a_l)) + d_s_g(:)=dom_att(:) + ELSEIF (ANY(dom_att(:) /= d_s_g(:))) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_size_local" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_s_l(a_l,f_nb_in)) + ENDIF + d_s_l(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_position_first" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_p_f(a_l,f_nb_in)) + ENDIF + d_p_f(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_position_last" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_p_l(a_l,f_nb_in)) + ENDIF + d_p_l(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_halo_size_start" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_h_s(a_l,f_nb_in)) + ENDIF + d_h_s(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_halo_size_end" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_h_e(a_l,f_nb_in)) + ENDIF + d_h_e(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_type" + c_wn2 = " " + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),c_wn2) + CALL strlowercase (c_wn2) + IF (iw == 1) THEN + IF ( (TRIM(c_wn2) == "box") & + & .OR.(TRIM(c_wn2) == "apple") ) THEN + c_d_n = c_wn2 + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "type "//TRIM(c_wn2)//" not (yet) supported") + ENDIF + ELSEIF (TRIM(c_wn2) /= TRIM(c_d_n)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + CALL flrb_cf (iw,l_ocf) +!--- + ENDDO +!- + IF (i_v_lev >= 2) THEN + WRITE (UNIT=*,FMT='("")') + WRITE (*,'(" From the first file : ")') + WRITE (*,'(" Number of dimensions : ",I2)') f_d_nb + WRITE (*,'(" Idents : ",(10(1X,I4),:))') f_d_i(1:f_d_nb) + WRITE (*,'(" Lengths : ",(10(1X,I4),:))') f_d_l(1:f_d_nb) + WRITE (*,'(" Names: ")') + DO i=1,f_d_nb + WRITE (*,'(" """,A,"""")') TRIM(f_d_nm(i)) + ENDDO + IF (f_d_ul > 0) THEN + WRITE (*,'(" Unlimited dimension id : ",I2)') f_d_i(f_d_ul) + ENDIF + WRITE (*,'(" Number of variables : ",I2)') f_v_nb + WRITE (*,'(" Names: ")') + DO i=1,f_v_nb + WRITE (*,'(" """,A,"""")') TRIM(f_v_nm(i)) + ENDDO + WRITE (*,'(" Number of global attributes : ",I2)') f_a_nb + WRITE (*,'(" Names: ")') + DO i=1,f_a_nb + WRITE (*,'(" """,A,"""")') TRIM(f_a_nm(i)) + ENDDO + ENDIF + IF (i_v_lev >= 3) THEN + WRITE (UNIT=*,FMT='("")') + WRITE (*,'(" From input files : ")') + WRITE (*,'(" Total number of DOMAINS : ",I4)') d_n_t + WRITE (*,'(" DOMAIN_dimensions_ids :",(10(1X,I5),:))') d_d_i(:) + WRITE (*,'(" DOMAIN_size_global :",(10(1X,I5),:))') d_s_g(:) + WRITE (*,'(" DOMAIN_type : """,(A),"""")') TRIM(c_d_n) + DO iw=1,f_nb_in + WRITE (*,'(" File : ",A)') TRIM(f_nm(iw)) + WRITE (*,'(" d_s_l :",(10(1X,I5),:))') d_s_l(:,iw) + WRITE (*,'(" d_p_f :",(10(1X,I5),:))') d_p_f(:,iw) + WRITE (*,'(" d_p_l :",(10(1X,I5),:))') d_p_l(:,iw) + WRITE (*,'(" d_h_s :",(10(1X,I5),:))') d_h_s(:,iw) + IF (TRIM(c_d_n) == "apple") THEN + IF (COUNT(d_h_s(:,iw) /= 0) > 1) THEN + CALL ipslerr (3,"flio_rbld", & + & "Beginning offset is not yet supported", & + & "for more than one dimension"," ") + ENDIF + ENDIF + WRITE (*,'(" d_h_e :",(10(1X,I5),:))') d_h_e(:,iw) + IF (TRIM(c_d_n) == "apple") THEN + IF (COUNT(d_h_e(:,iw) /= 0) > 1) THEN + CALL ipslerr (3,"flio_rbld", & + & "Ending offset is not yet supported", & + & "for more than one dimension"," ") + ENDIF + ENDIF + ENDDO + ENDIF +!- +!--------------------------------------- +! Create the dimensionned output file +!--------------------------------------- +!- +! Define the dimensions used in the output file + DO id=1,f_d_nb + DO i=1,SIZE(d_d_i) + IF (f_d_i(id) == d_d_i(i)) THEN + f_d_l(id) = d_s_g(i) + ENDIF + ENDDO + ENDDO +!- + IF (f_d_ul > 0) THEN + i = f_d_l(f_d_ul); f_d_l(f_d_ul) = -1; + ENDIF +!- +! Create the output file + CALL fliocrfd (TRIM(f_nm(f_nb)),f_d_nm,f_d_l,f_id_o,c_f_n=c_wn1) +!- + IF (f_d_ul > 0) THEN + f_d_l(f_d_ul) = i; itmin = 1; itmax = f_d_l(f_d_ul); + ELSE + itmin = 1; itmax = 1; + ENDIF +!- +! open the first input file used to build the output file +!- + CALL flrb_of (1,f_id_i1) +!- +! define the global attributes in the output file +! copy all global attributes except those beginning by "DOMAIN_" +! eventually actualize the "file_name" attribute +!- + DO ia=1,f_a_nb + IF (INDEX(TRIM(f_a_nm(ia)),"DOMAIN_") == 1) CYCLE + IF (TRIM(f_a_nm(ia)) == "file_name") THEN + CALL flioputa (f_id_o,"?",TRIM(f_a_nm(ia)),TRIM(c_wn1)) + ELSE + CALL fliocpya (f_id_i1,"?",TRIM(f_a_nm(ia)),f_id_o,"?") + ENDIF + ENDDO +!- +! define the variables in the output file +!- + ALLOCATE(v_d_nb(f_v_nb)); v_d_nb(:) = 0; + ALLOCATE(v_d_ul(f_v_nb)); v_d_ul(:) = 0; + ALLOCATE(v_type(f_v_nb),v_d_i(flio_max_var_dims,f_v_nb)); + DO iv=1,f_v_nb +!-- get variable informations + CALL flioinqv & + & (f_id_i1,TRIM(f_v_nm(iv)),l_ex,v_t=v_type(iv), & + & nb_dims=v_d_nb(iv),id_dims=d_i,nb_atts=v_a_nb) +!-- define the new variable + IF (v_d_nb(iv) == 0) THEN + CALL fliodefv & + & (f_id_o,TRIM(f_v_nm(iv)),v_t=v_type(iv)) + ELSE + CALL fliodefv & + & (f_id_o,TRIM(f_v_nm(iv)),d_i(1:v_d_nb(iv)),v_t=v_type(iv)) + DO iw=1,v_d_nb(iv) + IF (f_d_ul > 0) THEN + IF (d_i(iw) == f_d_ul) THEN + v_d_ul(iv) = iw + ENDIF + ENDIF + ENDDO + v_d_i(1:v_d_nb(iv),iv) = d_i(1:v_d_nb(iv)) + ENDIF +!-- copy all variable attributes + IF (v_a_nb > 0) THEN + ALLOCATE(v_a_nm(v_a_nb)) + CALL flioinqv (f_id_i1,TRIM(f_v_nm(iv)),l_ex,cn_atts=v_a_nm) + DO ia=1,v_a_nb + CALL fliocpya & + & (f_id_i1,TRIM(f_v_nm(iv)),TRIM(v_a_nm(ia)), & + & f_id_o,TRIM(f_v_nm(iv))) + ENDDO + DEALLOCATE(v_a_nm) + ENDIF + ENDDO +!- +! update valid_min valid_max attributes values +!- + CALL flrb_rg +!- +!------------------------ +! Fill the output file +!------------------------ +!- + DO ik=1,2 + l_uld = (ik /= 1) + IF (l_uld) THEN + it1=itmin; it2=itmax; + ELSE + it1=1; it2=1; + ENDIF + DO it=it1,it2 + DO iv=1,f_v_nb + IF ( (.NOT.l_uld.AND.(v_d_ul(iv) > 0)) & + & .OR.(l_uld.AND.(v_d_ul(iv) <= 0)) ) THEN + CYCLE + ENDIF + IF (i_v_lev >= 3) THEN + WRITE (UNIT=*,FMT='("")') + IF (l_uld) THEN + WRITE (UNIT=*,FMT=*) "time step : ",it + ENDIF + WRITE (UNIT=*,FMT=*) "variable : ",TRIM(f_v_nm(iv)) + WRITE (UNIT=*,FMT=*) "var unlim dim : ",v_d_ul(iv) + ENDIF +!------ do the variable contains dimensions to be recombined ? + l_cgd = .FALSE. + i_n = 1 + DO i=1,SIZE(d_d_i) + l_cgd = ANY(v_d_i(1:v_d_nb(iv),iv) == d_d_i(i)) + l_cgd = l_cgd.AND.ANY(d_s_l(i,1:f_nb_in) /= d_s_g(i)) + IF (l_cgd) THEN + i_n = f_nb_in + EXIT + ENDIF + ENDDO + IF (v_d_nb(iv) > 0) THEN +!-------- Allocate io_i,io_n,ia_sm,io_sm,io_cm + i = v_d_nb(iv) + ALLOCATE(io_i(i),io_n(i),ia_sm(i),io_sm(i),io_cm(i)) +!-------- Default definition of io_i,io_n,io_sm,io_cm + io_i(:) = 1; io_n(:) = f_d_l(v_d_i(1:v_d_nb(iv),iv)); + ia_sm(:) = 1; io_sm(:) = 1; + IF (v_d_ul(iv) > 0) THEN + io_i(v_d_ul(iv))=it + io_n(v_d_ul(iv))=1 + io_sm(v_d_ul(iv))=it + ENDIF + io_cm(:) = io_n(:); +!-------- If needed, allocate offset + l_o_f = .FALSE.; l_o_m = .TRUE.; l_o_l = .FALSE.; + IF (TRIM(c_d_n) == "apple") THEN + ALLOCATE(ia_sf(i),io_sf(i),io_cf(i)) + ALLOCATE(ia_sl(i),io_sl(i),io_cl(i)) + ia_sf(:) = 1; io_sf(:) = 1; io_cf(:) = io_n(:); + ia_sl(:) = 1; io_sl(:) = 1; io_cl(:) = io_n(:); + IF (v_d_ul(iv) > 0) THEN + io_sf(v_d_ul(iv))=it + io_sl(v_d_ul(iv))=it + ENDIF + ENDIF +!-------- Initialize to zero variables data + ! approximate dimension + IF ( it == 1 .AND. l_cgd) THEN + ! Enter I*J I*J is larger thant total number of single files + if ( ((f_d_l(1)/(d_s_l(1,1)-3)) * (f_d_l(2)/(d_s_l(2,1)-3) )) .gt. d_n_t ) then + CALL ZeroFill (f_id_o, f_v_nm(iv), f_d_l, v_d_nb(iv), v_type(iv), v_d_i(1:v_d_nb(iv),iv)) + endif + ENDIF + ENDIF +!------ + DO i_i=1,i_n + IF (l_cgd) THEN +!---------- the variable contains dimensions to be recombined +!----------- +!---------- open each file containing a small piece of data + CALL flrb_of (i_i,f_id_i) +!----------- +!---------- do the variable has offset at first/last block ? + l_cof = .FALSE.; l_col = .FALSE.; + IF (TRIM(c_d_n) == "apple") THEN + L_BF: DO id=1,v_d_nb(iv) + DO i=1,SIZE(d_d_i) + IF (v_d_i(id,iv) == d_d_i(i)) THEN + l_cof = (d_h_s(i,i_i) /= 0) + IF (l_cof) EXIT L_BF + ENDIF + ENDDO + ENDDO L_BF + L_BL: DO id=1,v_d_nb(iv) + DO i=1,SIZE(d_d_i) + IF (v_d_i(id,iv) == d_d_i(i)) THEN + l_col = (d_h_e(i,i_i) /= 0) + IF (l_col) EXIT L_BL + ENDIF + ENDDO + ENDDO L_BL + ENDIF +!---------- if needed, redefine start and count for dimensions + l_o_f = .FALSE.; l_o_m = .TRUE.; l_o_l = .FALSE.; + DO id=1,v_d_nb(iv) + DO i=1,SIZE(d_d_i) + IF (v_d_i(id,iv) == d_d_i(i)) THEN + io_n(id) = d_p_l(i,i_i)-d_p_f(i,i_i)+1 + ia_sm(id) = 1 + io_sm(id) = d_p_f(i,i_i) + io_cm(id) = io_n(id) + IF (TRIM(c_d_n) == "box") THEN + ia_sm(id) = ia_sm(id)+d_h_s(i,i_i) + io_sm(id) = io_sm(id)+d_h_s(i,i_i) + io_cm(id) = io_cm(id)-d_h_s(i,i_i)-d_h_e(i,i_i) + ELSEIF (TRIM(c_d_n) == "apple") THEN + IF (l_cof) THEN + IF (d_h_s(i,i_i) /= 0) THEN + ia_sf(id) = 1+d_h_s(i,i_i) + io_sf(id) = d_p_f(i,i_i)+d_h_s(i,i_i) + io_cf(id) = io_n(id)-d_h_s(i,i_i) + ELSE + io_sf(id) = d_p_f(i,i_i) + io_cf(id) = 1 + ia_sm(id) = ia_sm(id)+1 + io_sm(id) = io_sm(id)+1 + io_cm(id) = io_cm(id)-1 + l_o_f = .TRUE. + ENDIF + ENDIF + IF (l_col) THEN + IF (d_h_e(i,i_i) /= 0) THEN + ia_sl(id) = 1 + io_sl(id) = d_p_f(i,i_i) + io_cl(id) = io_n(id)-d_h_e(i,i_i) + ELSE + io_cm(id) = io_cm(id)-1 + ia_sl(id) = 1+io_n(id)-1 + io_sl(id) = d_p_f(i,i_i)+io_n(id)-1 + io_cl(id) = 1 + l_o_l = .TRUE. + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + l_o_m = ALL(io_cm > 0) + ELSE +!---------- the data can be read/write in one piece + f_id_i = f_id_i1 + ENDIF +!--------- + IF (i_v_lev >= 3) THEN + WRITE (UNIT=*,FMT=*) & + & TRIM(f_nm(i_i))//" - "//TRIM(f_v_nm(iv)) + WRITE (UNIT=*,FMT=*) "io_i : ",io_i(:) + WRITE (UNIT=*,FMT=*) "io_n : ",io_n(:) + WRITE (UNIT=*,FMT=*) "l_o_f : ",l_o_f + IF (l_o_f) THEN + WRITE (UNIT=*,FMT=*) "ia_sf : ",ia_sf(:) + WRITE (UNIT=*,FMT=*) "io_sf : ",io_sf(:) + WRITE (UNIT=*,FMT=*) "io_cf : ",io_cf(:) + ENDIF + WRITE (UNIT=*,FMT=*) "l_o_m : ",l_o_m + IF (l_o_m) THEN + WRITE (UNIT=*,FMT=*) "ia_sm : ",ia_sm(:) + WRITE (UNIT=*,FMT=*) "io_sm : ",io_sm(:) + WRITE (UNIT=*,FMT=*) "io_cm : ",io_cm(:) + ENDIF + WRITE (UNIT=*,FMT=*) "l_o_l : ",l_o_l + IF (l_o_l) THEN + WRITE (UNIT=*,FMT=*) "ia_sl : ",ia_sl(:) + WRITE (UNIT=*,FMT=*) "io_sl : ",io_sl(:) + WRITE (UNIT=*,FMT=*) "io_cl : ",io_cl(:) + ENDIF + ENDIF +!--------- +!-------- Cases according to the type, shape and offsets of the data +!--------- + SELECT CASE (v_type(iv)) +!?INTEGERS of KIND 1 are not supported on all computers +!? CASE (flio_i1) !--- INTEGER 1 +!? SELECT CASE (v_d_nb(iv)) +!? CASE (0) !--- Scalar +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_0d) +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i1_0d) +!? CASE (1) !--- 1d array +!? ALLOCATE(i1_1d(io_n(1))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_1d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_1d(ib(1):ie(1)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_1d(ib(1):ie(1)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_1d(ib(1):ie(1)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_1d) +!? CASE (2) !--- 2d array +!? ALLOCATE(i1_2d(io_n(1),io_n(2))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_2d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_2d) +!? CASE (3) !--- 3d array +!? ALLOCATE(i1_3d(io_n(1),io_n(2),io_n(3))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_3d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_3d) +!? CASE (4) !--- 4d array +!? ALLOCATE(i1_4d(io_n(1),io_n(2),io_n(3),io_n(4))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_4d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_4d(ib(1):ie(1),ib(2):ie(2), & +!? & ib(3):ie(3),ib(4):ie(4)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_4d(ib(1):ie(1),ib(2):ie(2), & +!? & ib(3):ie(3),ib(4):ie(4)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_4d(ib(1):ie(1),ib(2):ie(2), & +!? & ib(3):ie(3),ib(4):ie(4)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_4d) +!? CASE (5) !--- 5d array +!? ALLOCATE(i1_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_5d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & +!? & ib(4):ie(4),ib(5):ie(5)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & +!? & ib(4):ie(4),ib(5):ie(5)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & +!? & ib(4):ie(4),ib(5):ie(5)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_5d) +!? END SELECT +!? CASE (flio_i2) !--- INTEGER 2 + CASE (flio_i1,flio_i2) !--- INTEGER 1/INTEGER 2 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i2_0d) + CASE (1) !--- 1d array + ALLOCATE(i2_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_1d) + CASE (2) !--- 2d array + ALLOCATE(i2_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_2d) + CASE (3) !--- 3d array + ALLOCATE(i2_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_3d) + CASE (4) !--- 4d array + ALLOCATE(i2_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_4d) + CASE (5) !--- 5d array + ALLOCATE(i2_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_5d) + END SELECT + CASE (flio_i4) !--- INTEGER 4 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i4_0d) + CASE (1) !--- 1d array + ALLOCATE(i4_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_1d) + CASE (2) !--- 2d array + ALLOCATE(i4_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_2d) + CASE (3) !--- 3d array + ALLOCATE(i4_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_3d) + CASE (4) !--- 4d array + ALLOCATE(i4_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_4d) + CASE (5) !--- 5d array + ALLOCATE(i4_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_5d) + END SELECT + CASE (flio_r4) !--- REAL 4 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),r4_0d) + CASE (1) !--- 1d array + ALLOCATE(r4_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_1d) + CASE (2) !--- 2d array + ALLOCATE(r4_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_2d) + CASE (3) !--- 3d array + ALLOCATE(r4_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_3d) + CASE (4) !--- 4d array + ALLOCATE(r4_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_4d) + CASE (5) !--- 5d array + ALLOCATE(r4_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_5d) + END SELECT + CASE (flio_r8) !--- REAL 8 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),r8_0d) + CASE (1) !--- 1d array + ALLOCATE(r8_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_1d) + CASE (2) !--- 2d array + ALLOCATE(r8_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_2d) + CASE (3) !--- 3d array + ALLOCATE(r8_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_3d) + CASE (4) !--- 4d array + ALLOCATE(r8_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_4d) + CASE (5) !--- 5d array + ALLOCATE(r8_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_5d) + END SELECT + END SELECT +!-------- eventually close each file containing a small piece of data + CALL flrb_cf (i_i,l_ocf.AND.l_cgd.AND.(i_i /= 1)) + ENDDO +!------ If needed, deallocate io_* arrays + IF (v_d_nb(iv) > 0) THEN + DEALLOCATE(io_i,io_n,ia_sm,io_sm,io_cm) + IF (TRIM(c_d_n) == "apple") THEN + DEALLOCATE(ia_sf,io_sf,io_cf) + DEALLOCATE(ia_sl,io_sl,io_cl) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +!- +!------------------- +! Ending the work +!------------------- +!- +! Close files + CALL flrb_cf (0,.TRUE.) +!- +! Deallocate + DEALLOCATE(f_nm,f_a_id) + DEALLOCATE(f_d_nm,f_v_nm,f_a_nm) + DEALLOCATE(f_d_i,f_d_l) + DEALLOCATE(v_d_nb,v_d_ul,v_type,v_d_i) + DEALLOCATE(d_d_i,d_s_g) + DEALLOCATE(d_s_l,d_p_f,d_p_l,d_h_s,d_h_e) +!- + IF (i_v_lev >= 1) THEN +!-- elapsed and cpu time computation + CALL cpu_time (t_cpu_end) + CALL system_clock(count=nb_cc_end) + WRITE (UNIT=*,FMT='("")') + WRITE (UNIT=*,fmt='(" elapsed time (s) : ",1PE11.4)') & + & REAL(nb_cc_end-nb_cc_ini)/REAL(nb_cc_sec) + WRITE (UNIT=*,fmt='(" CPU time (s) : ",1PE11.4)') & + & t_cpu_end-t_cpu_ini + ENDIF +!======= +CONTAINS +!======= +SUBROUTINE flrb_of (i_f_n,i_f_i) +!--------------------------------------------------------------------- +! Open the file of number "i_f_n" if necessary, +! and returns its identifier in "i_f_i". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: i_f_n + INTEGER,INTENT(OUT) :: i_f_i +!--------------------------------------------------------------------- + IF (f_a_id(i_f_n) < 0) THEN + CALL flioopfd (TRIM(f_nm(i_f_n)),i_f_i) + f_a_id(i_f_n) = i_f_i + ELSE + i_f_i = f_a_id(i_f_n) + ENDIF +!--------------------- +END SUBROUTINE flrb_of +!=== +SUBROUTINE flrb_cf (i_f_n,l_cf) +!--------------------------------------------------------------------- +! Close the file of number "i_f_n" if "l_cf" is TRUE. +! Close all files if "i_f_n <= 0". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: i_f_n + LOGICAL,INTENT(IN) :: l_cf +!--------------------------------------------------------------------- + IF (i_f_n <= 0) THEN + CALL flioclo () + f_a_id(:) = -1 + ELSE + IF (l_cf) THEN + IF (f_a_id(i_f_n) < 0) THEN + CALL ipslerr (2,"flio_rbld", & + & "The file",TRIM(f_nm(i_f_n)),"is already closed") + ELSE + CALL flioclo (f_a_id(i_f_n)) + f_a_id(i_f_n) = -1 + ENDIF + ENDIF + ENDIF +!--------------------- +END SUBROUTINE flrb_cf +!=== +SUBROUTINE flrb_rg +!--------------------------------------------------------------------- +! Update valid_min valid_max attributes values +!--------------------------------------------------------------------- + INTEGER :: k,j + LOGICAL :: l_vmin,l_vmax + INTEGER(KIND=i_4) :: i4_vmin,i4_vmax + REAL(KIND=r_4) :: r4_vmin,r4_vmax + REAL(KIND=r_8) :: r8_vmin,r8_vmax +!--------------------------------------------------------------------- + DO k=1,f_v_nb +!-- get attribute informations + CALL flioinqa & + & (f_id_i1,TRIM(f_v_nm(k)),'valid_min',l_vmin,a_t=a_type) + CALL flioinqa & + & (f_id_i1,TRIM(f_v_nm(k)),'valid_max',l_vmax,a_t=a_type) +!--- + IF (l_vmin.OR.l_vmax) THEN +!---- get values of min/max + SELECT CASE (a_type) + CASE (flio_i1,flio_i2,flio_i4) !--- INTEGER 1/2/4 + DO j=1,f_nb_in + CALL flrb_of (j,f_id_i) + IF (l_vmin) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",i4_0d) + IF (j == 1) THEN + i4_vmin = i4_0d + ELSE + i4_vmin = MIN(i4_vmin,i4_0d) + ENDIF + ENDIF + IF (l_vmax) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",i4_0d) + IF (j == 1) THEN + i4_vmax = i4_0d + ELSE + i4_vmax = MAX(i4_vmax,i4_0d) + ENDIF + ENDIF + CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) + ENDDO + IF (l_vmin) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",i4_vmin) + ENDIF + IF (l_vmax) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",i4_vmax) + ENDIF + CASE (flio_r4) !--- REAL 4 + DO j=1,f_nb_in + CALL flrb_of (j,f_id_i) + IF (l_vmin) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",r4_0d) + IF (j == 1) THEN + r4_vmin = r4_0d + ELSE + r4_vmin = MIN(r4_vmin,r4_0d) + ENDIF + ENDIF + IF (l_vmax) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",r4_0d) + IF (j == 1) THEN + r4_vmax = r4_0d + ELSE + r4_vmax = MAX(r4_vmax,r4_0d) + ENDIF + ENDIF + CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) + ENDDO + IF (l_vmin) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",r4_vmin) + ENDIF + IF (l_vmax) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",r4_vmax) + ENDIF + CASE (flio_r8) !--- REAL 8 + DO j=1,f_nb_in + CALL flrb_of (j,f_id_i) + IF (l_vmin) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",r8_0d) + IF (j == 1) THEN + r8_vmin = r8_0d + ELSE + r8_vmin = MIN(r8_vmin,r8_0d) + ENDIF + ENDIF + IF (l_vmax) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",r8_0d) + IF (j == 1) THEN + r8_vmax = r8_0d + ELSE + r8_vmax = MAX(r8_vmax,r8_0d) + ENDIF + ENDIF + CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) + ENDDO + IF (l_vmin) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",r8_vmin) + ENDIF + IF (l_vmax) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",r8_vmax) + ENDIF + END SELECT + ENDIF + ENDDO +!--------------------- +END SUBROUTINE flrb_rg +!=== +SUBROUTINE ZeroFill(f_id_o,f_v_nm,f_d_l,v_d_nb,v_type,v_d_i) + + IMPLICIT NONE +! Character length + INTEGER,PARAMETER :: chlen=256 + + INTEGER :: v_d_nb, v_type ! variable # of dims, variable type, var Unlim dimension + INTEGER :: f_id_o ! Output file ID + INTEGER,DIMENSION(:) :: f_d_l, v_d_i ! Global dimensions, variable dimensio ID + CHARACTER(LEN=chlen) :: f_v_nm ! Variable name + INTEGER,DIMENSION(:),ALLOCATABLE :: dims + + INTEGER(KIND=i_2) :: i2_0d + INTEGER(KIND=i_2), ALLOCATABLE :: i2_1d(:), i2_2d(:,:), i2_3d(:,:,:), i2_4d(:,:,:,:), i2_5d(:,:,:,:,:) + INTEGER(KIND=i_4) :: i4_0d + INTEGER(KIND=i_4), ALLOCATABLE :: i4_1d(:), i4_2d(:,:), i4_3d(:,:,:), i4_4d(:,:,:,:), i4_5d(:,:,:,:,:) + REAL(KIND=r_4) :: r4_0d + REAL(KIND=r_4), ALLOCATABLE :: r4_1d(:), r4_2d(:,:), r4_3d(:,:,:), r4_4d(:,:,:,:), r4_5d(:,:,:,:,:) + REAL(KIND=r_8) :: r8_0d + REAL(KIND=r_8), ALLOCATABLE :: r8_1d(:), r8_2d(:,:), r8_3d(:,:,:), r8_4d(:,:,:,:), r8_5d(:,:,:,:,:) + + ! write(*,*) ' Into my sub... TOM' + ! write(*,*) f_id_o, TRIM(f_v_nm), v_d_nb , v_type + write(*,*) 'Variable: ',TRIM(f_v_nm), ' intiliazed to zero' + write(*,*) + + ! define variable dimension + ALLOCATE(dims(v_d_nb)) + dims=f_d_l(v_d_i) + SELECT CASE(v_type) + ! INTEGER 1 and 2 + CASE (flio_i1,flio_i2) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(i2_1d(dims(1))) + i2_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_1d) + DEALLOCATE(i2_1d) + CASE(2) + ALLOCATE(i2_2d(dims(1),dims(2))) + i2_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_2d) + DEALLOCATE(i2_2d) + CASE(3) + ALLOCATE(i2_3d(dims(1),dims(2),dims(3))) + i2_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_3d) + DEALLOCATE(i2_3d) + CASE(4) + ALLOCATE(i2_4d(dims(1),dims(2),dims(3),dims(4))) + i2_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_4d) + DEALLOCATE(i2_4d) + CASE(5) + ALLOCATE(i2_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + i2_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_5d) + DEALLOCATE(i2_5d) + END SELECT + ! INTEGER 4 + CASE (flio_i4) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(i4_1d(dims(1))) + i4_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_1d) + DEALLOCATE(i4_1d) + CASE(2) + ALLOCATE(i4_2d(dims(1),dims(2))) + i4_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_2d) + DEALLOCATE(i4_2d) + CASE(3) + ALLOCATE(i4_3d(dims(1),dims(2),dims(3))) + i4_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_3d) + DEALLOCATE(i4_3d) + CASE(4) + ALLOCATE(i4_4d(dims(1),dims(2),dims(3),dims(4))) + i4_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_4d) + DEALLOCATE(i4_4d) + CASE(5) + ALLOCATE(i4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + i4_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_5d) + DEALLOCATE(i4_5d) + END SELECT + ! FLOAT 4 + CASE (flio_r4) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(r4_1d(dims(1))) + r4_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_1d) + DEALLOCATE(r4_1d) + CASE(2) + ALLOCATE(r4_2d(dims(1),dims(2))) + r4_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_2d) + DEALLOCATE(r4_2d) + CASE(3) + ALLOCATE(r4_3d(dims(1),dims(2),dims(3))) + r4_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_3d) + DEALLOCATE(r4_3d) + CASE(4) + ALLOCATE(r4_4d(dims(1),dims(2),dims(3),dims(4))) + r4_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_4d) + DEALLOCATE(r4_4d) + CASE(5) + ALLOCATE(r4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + r4_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_5d) + DEALLOCATE(r4_5d) + END SELECT + ! FLOAT 8 + CASE (flio_r8) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(r8_1d(dims(1))) + r8_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_1d) + DEALLOCATE(r8_1d) + CASE(2) + ALLOCATE(r8_2d(dims(1),dims(2))) + r8_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_2d) + DEALLOCATE(r8_2d) + CASE(3) + ALLOCATE(r8_3d(dims(1),dims(2),dims(3))) + r8_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_3d) + DEALLOCATE(r8_3d) + CASE(4) + ALLOCATE(r8_4d(dims(1),dims(2),dims(3),dims(4))) + r8_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_4d) + DEALLOCATE(r8_4d) + CASE(5) + ALLOCATE(r8_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + r8_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_5d) + DEALLOCATE(r8_5d) + END SELECT + END SELECT + + DEALLOCATE (dims) + +END SUBROUTINE +!=== +!-------------------- +END PROGRAM flio_rbld diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/9b/9bdefc9c596a18f083ab6e9f5fdb82419fde6ff0.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/9b/9bdefc9c596a18f083ab6e9f5fdb82419fde6ff0.svn-base new file mode 100644 index 0000000..df74192 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/9b/9bdefc9c596a18f083ab6e9f5fdb82419fde6ff0.svn-base @@ -0,0 +1,1044 @@ +MODULE calendar +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- This is the calendar which going to be used to do all +!- calculations on time. Three types of calendars are possible : +!- +!- - gregorian : +!- The normal calendar. The time origin for the +!- julian day in this case is 24 Nov -4713 +!- (other names : 'standard','proleptic_gregorian') +!- - noleap : +!- A 365 day year without leap years. +!- The origin for the julian days is in this case 1 Jan 0 +!- (other names : '365_day','365d') +!- - all_leap : +!- A 366 day year with leap years. +!- The origin for the julian days is in this case ???? +!- (other names : '366_day','366d' +!- - julian : +!- same as gregorian, but with all leap century years +!- - xxxd : +!- Year of xxx days with month of equal length. +!- The origin for the julian days is then also 1 Jan 0 +!- +!- As one can see it is difficult to go from one calendar to the other. +!- All operations involving julian days will be wrong. +!- This calendar will lock as soon as possible +!- the length of the year and forbid any further modification. +!- +!- For the non leap-year calendar the method is still brute force. +!- We need to find an Integer series which takes care of the length +!- of the various month. (Jan) +!- +!- one_day : one day in seconds +!- one_year : one year in days +!--------------------------------------------------------------------- + USE stringop,ONLY : strlowercase + USE errioipsl,ONLY : ipslerr +!- + PRIVATE + PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, & + & ioget_calendar,ioget_mon_len,ioget_year_len,itau2date, & + & ioget_timestamp,ioconf_startdate,itau2ymds, & + & time_diff,time_add,lock_calendar +!- + INTERFACE ioget_calendar + MODULE PROCEDURE & + & ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str + END INTERFACE +!- + INTERFACE ioconf_startdate + MODULE PROCEDURE & + & ioconf_startdate_simple,ioconf_startdate_internal, & + & ioconf_startdate_ymds + END INTERFACE +!- + REAL,PARAMETER :: one_day = 86400.0 + LOGICAL,SAVE :: lock_startdate = .FALSE. +!- + CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX' +!- +!- Description of calendar +!- + CHARACTER(LEN=20),SAVE :: calendar_used="gregorian" + LOGICAL,SAVE :: lock_one_year = .FALSE. + REAL,SAVE :: one_year = 365.2425 + INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/) +!- + CHARACTER(LEN=3),PARAMETER :: & + & cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', & + & 'JUL','AUG','SEP','OCT','NOV','DEC'/) +!- + REAL,SAVE :: start_day,start_sec +!- +CONTAINS +!- +!=== +!- +SUBROUTINE lock_calendar (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "lock_calendar" routine +!! allows to lock or unlock the calendar, +!! and to know the current status of the calendar. +!! Be careful ! +!! +!! SUBROUTINE lock_calendar (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the calendar +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the calendar +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = lock_one_year + ENDIF + IF (PRESENT(new_status)) THEN + lock_one_year = new_status + ENDIF +!--------------------------- +END SUBROUTINE lock_calendar +!- +!=== +!- +SUBROUTINE ymds2ju (year,month,day,sec,julian) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL,INTENT(IN) :: sec +!- + REAL,INTENT(OUT) :: julian +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!- + julian = julian_day+julian_sec/one_day +!--------------------- +END SUBROUTINE ymds2ju +!- +!=== +!- +SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!--------------------------------------------------------------------- +!- Converts year, month, day and seconds into a julian day +!- +!- In 1968 in a letter to the editor of Communications of the ACM +!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel +!- and Thomas C. Van Flandern presented such an algorithm. +!- +!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm +!- +!- In the case of the Gregorian calendar we have chosen to use +!- the Lilian day numbers. This is the day counter which starts +!- on the 15th October 1582. +!- This is the day at which Pope Gregory XIII introduced the +!- Gregorian calendar. +!- Compared to the true Julian calendar, which starts some +!- 7980 years ago, the Lilian days are smaler and are dealt with +!- easily on 32 bit machines. With the true Julian days you can only +!- the fraction of the day in the real part to a precision of +!- a 1/4 of a day with 32 bits. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL,INTENT(IN) :: sec +!- + INTEGER,INTENT(OUT) :: julian_day + REAL,INTENT(OUT) :: julian_sec +!- + INTEGER :: jd,m,y,d,ml +!--------------------------------------------------------------------- + lock_one_year = .TRUE. +!- + m = month + y = year + d = day +!- +!- We deduce the calendar from the length of the year as it +!- is faster than an INDEX on the calendar variable. +!- + IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN +!-- "Gregorian" + jd = (1461*(y+4800+INT((m-14)/12)))/4 & + & +(367*(m-2-12*(INT((m-14)/12))))/12 & + & -(3*((y+4900+INT((m-14)/12))/100))/4 & + & +d-32075 + jd = jd-2299160 + ELSE IF ( (ABS(one_year-365.0) <= EPSILON(one_year)) & + & .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN +!-- "No leap" or "All leap" + ml = SUM(mon_len(1:m-1)) + jd = y*NINT(one_year)+ml+(d-1) + ELSE +!-- Calendar with regular month + ml = NINT(one_year/12.) + jd = y*NINT(one_year)+(m-1)*ml+(d-1) + ENDIF +!- + julian_day = jd + julian_sec = sec +!------------------------------ +END SUBROUTINE ymds2ju_internal +!- +!=== +!- +SUBROUTINE ju2ymds (julian,year,month,day,sec) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(IN) :: julian +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL,INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + julian_day = INT(julian) + julian_sec = (julian-julian_day)*one_day +!- + CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec) +!--------------------- +END SUBROUTINE ju2ymds +!- +!=== +!- +SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec) +!--------------------------------------------------------------------- +!- This subroutine computes from the julian day the year, +!- month, day and seconds +!- +!- In 1968 in a letter to the editor of Communications of the ACM +!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel +!- and Thomas C. Van Flandern presented such an algorithm. +!- +!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm +!- +!- In the case of the Gregorian calendar we have chosen to use +!- the Lilian day numbers. This is the day counter which starts +!- on the 15th October 1582. This is the day at which Pope +!- Gregory XIII introduced the Gregorian calendar. +!- Compared to the true Julian calendar, which starts some 7980 +!- years ago, the Lilian days are smaler and are dealt with easily +!- on 32 bit machines. With the true Julian days you can only the +!- fraction of the day in the real part to a precision of a 1/4 of +!- a day with 32 bits. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: julian_day + REAL,INTENT(IN) :: julian_sec +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL,INTENT(OUT) :: sec +!- + INTEGER :: l,n,i,jd,j,d,m,y,ml + INTEGER :: add_day + REAL :: eps_day +!--------------------------------------------------------------------- + eps_day = SPACING(one_day) + lock_one_year = .TRUE. +!- + jd = julian_day + sec = julian_sec + IF (sec > (one_day-eps_day)) THEN + add_day = INT(sec/one_day) + sec = sec-add_day*one_day + jd = jd+add_day + ENDIF + IF (sec < -eps_day) THEN + sec = sec+one_day + jd = jd-1 + ENDIF +!- + IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN +!-- Gregorian + jd = jd+2299160 +!- + l = jd+68569 + n = (4*l)/146097 + l = l-(146097*n+3)/4 + i = (4000*(l+1))/1461001 + l = l-(1461*i)/4+31 + j = (80*l)/2447 + d = l-(2447*j)/80 + l = j/11 + m = j+2-(12*l) + y = 100*(n-49)+i+l + ELSE IF ( (ABS(one_year-365.0) <= EPSILON(one_year)) & + & .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN +!-- No leap or All leap + y = jd/NINT(one_year) + l = jd-y*NINT(one_year) + m = 1 + ml = 0 + DO WHILE (ml+mon_len(m) <= l) + ml = ml+mon_len(m) + m = m+1 + ENDDO + d = l-ml+1 + ELSE +!-- others + ml = NINT(one_year/12.) + y = jd/NINT(one_year) + l = jd-y*NINT(one_year) + m = (l/ml)+1 + d = l-(m-1)*ml+1 + ENDIF +!- + day = d + month = m + year = y +!------------------------------ +END SUBROUTINE ju2ymds_internal +!- +!=== +!- +SUBROUTINE tlen2itau (input_str,dt,date,itau) +!--------------------------------------------------------------------- +!- This subroutine transforms a string containing a time length +!- into a number of time steps. +!- To do this operation the date (in julian days is needed as the +!- length of the month varies. +!- The following convention is used : +!- n : n time steps +!- nS : n seconds is transformed into itaus +!- nH : n hours +!- nD : n days +!- nM : n month +!- nY : n years +!- Combinations are also possible +!- nYmD : nyears plus m days ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: input_str + REAL,INTENT(IN) :: dt,date +!- + INTEGER,INTENT(OUT) :: itau +!- + INTEGER :: y_pos,m_pos,d_pos,h_pos,s_pos + INTEGER :: read_time + CHARACTER(LEN=13) :: fmt + CHARACTER(LEN=80) :: tmp_str +!- + INTEGER :: year,month,day + REAL :: sec,date_new,dd,ss +!--------------------------------------------------------------------- + itau = 0 + CALL ju2ymds (date,year,month,day,sec) +!- + y_pos = MAX(INDEX(input_str,'y'),INDEX(input_str,'Y')) + m_pos = MAX(INDEX(input_str,'m'),INDEX(input_str,'M')) + d_pos = MAX(INDEX(input_str,'d'),INDEX(input_str,'D')) + h_pos = MAX(INDEX(input_str,'h'),INDEX(input_str,'H')) + s_pos = MAX(INDEX(input_str,'s'),INDEX(input_str,'S')) +!- + IF (MAX(y_pos,m_pos,d_pos,s_pos) > 0) THEN + tmp_str = input_str + DO WHILE ( MAX(y_pos,m_pos,d_pos,s_pos) > 0) +!---- WRITE(*,*) tmp_str +!---- WRITE(*,*) y_pos,m_pos,d_pos,s_pos + IF (y_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') y_pos-1 + READ(tmp_str(1:y_pos-1),fmt) read_time + CALL ymds2ju (year+read_time,month,day,sec,date_new) + dd = date_new-date + ss = INT(dd)*one_day+dd-INT(dd) + itau = itau+NINT(ss/dt) + tmp_str = tmp_str(y_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (m_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') m_pos-1 + READ(tmp_str(1:m_pos-1),fmt) read_time + CALL ymds2ju (year,month+read_time,day,sec,date_new) + dd = date_new-date + ss = INT(dd)*one_day+dd-INT(dd) + itau = itau+NINT(ss/dt) + tmp_str = tmp_str(m_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (d_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') d_pos-1 + READ(tmp_str(1:d_pos-1),fmt) read_time + itau = itau+NINT(read_time*one_day/dt) + tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (h_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') h_pos-1 + READ(tmp_str(1:h_pos-1),fmt) read_time + itau = itau+NINT(read_time*60.*60./dt) + tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (s_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') s_pos-1 + READ(tmp_str(1:s_pos-1),fmt) read_time + itau = itau+NINT(read_time/dt) + tmp_str = tmp_str(s_pos+1:LEN_TRIM(tmp_str)) + ENDIF +!- + y_pos = MAX(INDEX(tmp_str,'y'),INDEX(tmp_str,'Y')) + m_pos = MAX(INDEX(tmp_str,'m'),INDEX(tmp_str,'M')) + d_pos = MAX(INDEX(tmp_str,'d'),INDEX(tmp_str,'D')) + h_pos = MAX(INDEX(tmp_str,'h'),INDEX(tmp_str,'H')) + s_pos = MAX(INDEX(tmp_str,'s'),INDEX(tmp_str,'S')) + ENDDO + ELSE + WRITE(fmt,'("(I",I10.10,")")') LEN_TRIM(input_str) + READ(input_str(1:LEN_TRIM(input_str)),fmt) itau + ENDIF +!----------------------- +END SUBROUTINE tlen2itau +!- +!=== +!- +REAL FUNCTION itau2date (itau,date0,deltat) +!--------------------------------------------------------------------- +!- This function transforms itau into a date. The date with which +!- the time axis is going to be labeled +!- +!- INPUT +!- itau : current time step +!- date0 : Date at which itau was equal to 0 +!- deltat : time step between itau s +!- +!- OUTPUT +!- itau2date : Date for the given itau +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: itau + REAL :: date0,deltat +!--------------------------------------------------------------------- + itau2date = REAL(itau)*deltat/one_day+date0 +!--------------------- +END FUNCTION itau2date +!- +!=== +!- +SUBROUTINE itau2ymds (itau,deltat,year,month,day,sec) +!--------------------------------------------------------------------- +!- This subroutine transforms itau into a date. The date with which +!- the time axis is going to be labeled +!- +!- INPUT +!- itau : current time step +!- deltat : time step between itau s +!- +!- OUTPUT +!- year : year +!- month : month +!- day : day +!- sec : seconds since midnight +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: itau + REAL,INTENT(IN) :: deltat +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL,INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + IF (.NOT.lock_startdate) THEN + CALL ipslerr (2,'itau2ymds', & + & 'You try to call this function, itau2ymds, but you didn''t', & + & ' call ioconf_startdate to initialize date0 in calendar.', & + & ' Please call ioconf_startdate before itau2ymds.') + ENDIF + julian_day = start_day + julian_sec = start_sec+REAL(itau)*deltat + CALL ju2ymds_internal (julian_day,julian_sec,year,month,day,sec) +!----------------------- +END SUBROUTINE itau2ymds +!- +!=== +!- +REAL FUNCTION dtchdate (itau,date0,old_dt,new_dt) +!--------------------------------------------------------------------- +!- This function changes the date so that the simulation can +!- continue with the same itau but a different dt. +!- +!- INPUT +!- itau : current time step +!- date0 : Date at which itau was equal to 0 +!- old_dt : Old time step between itaus +!- new_dt : New time step between itaus +!- +!- OUTPUT +!- dtchdate : Date for the given itau +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: itau + REAL,INTENT(IN) :: date0,old_dt,new_dt +!- + REAL :: rtime +!--------------------------------------------------------------------- + rtime = itau2date (itau,date0,old_dt) + dtchdate = rtime-REAL(itau)*new_dt/one_day +!-------------------- +END FUNCTION dtchdate +!- +!=== +!- +SUBROUTINE isittime & + & (itau,date0,dt,freq,last_action,last_check,do_action) +!--------------------------------------------------------------------- +!- This subroutine checks the time as come for a given action. +!- This is computed from the current time-step(itau). +!- Thus we need to have the time delta (dt), the frequency +!- of the action (freq) and the last time it was done +!- (last_action in units of itau). +!- In order to extrapolate when will be the next check we need +!- the time step of the last call (last_check). +!- +!- The test is done on the following condition : +!- the distance from the current time to the time for the next +!- action is smaller than the one from the next expected +!- check to the next action. +!- When the test is done on the time steps simplifications make +!- it more difficult to read in the code. +!- For the real time case it is easier to understand ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: itau + REAL,INTENT(IN) :: dt,freq + INTEGER,INTENT(IN) :: last_action,last_check + REAL,INTENT(IN) :: date0 +!- + LOGICAL,INTENT(OUT) :: do_action +!- + REAL :: dt_action,dt_check + REAL :: date_last_act,date_next_check,date_next_act, & + & date_now,date_mp1,date_mpf + INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau + INTEGER :: yearp,dayp + REAL :: sec,secp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) THEN + WRITE(*,*) & + & "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check + ENDIF +!- + IF (last_check >= 0) THEN + dt_action = (itau-last_action)*dt + dt_check = (itau-last_check)*dt + next_check_itau = itau+(itau-last_check) +!- +!-- We are dealing with frequencies in seconds and thus operation +!-- can be done on the time steps. +!- + IF (freq > 0) THEN + IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN + do_action = .TRUE. + ELSE + do_action = .FALSE. + ENDIF +!- +!---- Here we deal with frequencies in month and work on julian days. +!- + ELSE + date_now = itau2date (itau,date0,dt) + date_last_act = itau2date (last_action,date0,dt) + CALL ju2ymds (date_last_act,year,month,day,sec) + monthp1 = month-freq + yearp = year +!- +!---- Here we compute what logically should be the next month +!- + DO WHILE (monthp1 >= 13) + yearp = yearp+1 + monthp1 = monthp1-12 + END DO + CALL ymds2ju (yearp,monthp1,day,sec,date_mpf) +!- +!---- But it could be that because of a shorter month or a bad +!---- starting date that we end up further than we should be. +!---- Thus we compute the first day of the next month. +!---- We can not be beyond this date and if we are close +!---- then we will take it as it is better. +!- + monthp1 = month+ABS(freq) + yearp=year + DO WHILE (monthp1 >= 13) + yearp = yearp+1 + monthp1 = monthp1-12 + END DO + dayp = 1 + secp = 0.0 + CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1) +!- +!---- If date_mp1 is smaller than date_mpf or only less than 4 days +!---- larger then we take it. This needed to ensure that short month +!---- like February do not mess up the thing ! +!- + IF (date_mp1-date_mpf < 4.) THEN + date_next_act = date_mp1 + ELSE + date_next_act = date_mpf + ENDIF + date_next_check = itau2date (next_check_itau,date0,dt) +!- +!---- Transform the dates into time-steps for the needed precisions. +!- + next_act_itau = & + & last_action+INT((date_next_act-date_last_act)*(one_day/dt)) +!----- + IF ( ABS(itau-next_act_itau) & + & <= ABS( next_check_itau-next_act_itau)) THEN + do_action = .TRUE. + IF (check) THEN + WRITE(*,*) & + & 'ACT-TIME : itau, next_act_itau, next_check_itau : ', & + & itau,next_act_itau,next_check_itau + CALL ju2ymds (date_now,year,month,day,sec) + WRITE(*,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec + WRITE(*,*) & + & 'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf + ENDIF + ELSE + do_action = .FALSE. + ENDIF + ENDIF +!- + IF (check) THEN + WRITE(*,*) "isittime 2.0 ", & + & date_next_check,date_next_act,ABS(dt_action-freq), & + & ABS(dt_action+dt_check-freq),dt_action,dt_check, & + & next_check_itau,do_action + ENDIF + ELSE + do_action=.FALSE. + ENDIF +!---------------------- +END SUBROUTINE isittime +!- +!=== +!- +SUBROUTINE ioconf_calendar (str) +!--------------------------------------------------------------------- +!- This routine allows to configure the calendar to be used. +!- This operation is only allowed once and the first call to +!- ymds2ju or ju2ymsd will lock the current configuration. +!- the argument to ioconf_calendar can be any of the following : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: str +!- + INTEGER :: leng,ipos + CHARACTER(LEN=20) :: str_w +!--------------------------------------------------------------------- +!- +! Clean up the string ! +!- + str_w = str + CALL strlowercase (str_w) +!- + IF (.NOT.lock_one_year) THEN +!--- + lock_one_year=.TRUE. +!--- + SELECT CASE(TRIM(str_w)) + CASE('gregorian','standard','proleptic_gregorian') + calendar_used = 'gregorian' + one_year = 365.2425 + mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) + CASE('noleap','365_day','365d') + calendar_used = 'noleap' + one_year = 365.0 + mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) + CASE('all_leap','366_day','366d') + calendar_used = 'all_leap' + one_year = 366.0 + mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/) + CASE('360_day','360d') + calendar_used = '360d' + one_year = 360.0 + mon_len(:)=(/30,30,30,30,30,30,30,30,30,30,30,30/) + CASE('julian') + calendar_used = 'julian' + one_year = 365.25 + mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) + CASE DEFAULT + ipos = INDEX(str_w,'d') + IF (ipos == 4) THEN + READ(str_w(1:3),'(I3)') leng + IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN + calendar_used = str_w + one_year = leng + mon_len(:) = leng/12 + ELSE + CALL ipslerr (3,'ioconf_calendar', & + & 'The length of the year as to be a modulo of 12', & + & 'so that it can be divided into 12 month of equal length', & + & TRIM(str_w)) + ENDIF + ELSE + CALL ipslerr (3,'ioconf_calendar', & + & 'Unrecognized input, please check the man pages.', & + & TRIM(str_w),' ') + ENDIF + END SELECT + ELSE IF (TRIM(str_w) /= TRIM(calendar_used)) THEN + WRITE(str_w,'(f10.4)') one_year + CALL ipslerr (2,'ioconf_calendar', & + & 'The calendar was already used or configured to : '// & + & TRIM(calendar_used)//'.', & + & 'You are not allowed to change it to : '//TRIM(str)//'.', & + & 'The following length of year is used : '//TRIM(ADJUSTL(str_w))) + ENDIF +!----------------------------- +END SUBROUTINE ioconf_calendar +!- +!=== +!- +SUBROUTINE ioconf_startdate_simple (julian) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(IN) :: julian +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + julian_day = INT(julian) + julian_sec = (julian-julian_day)*one_day +!- + CALL ioconf_startdate_internal (julian_day,julian_sec) +!------------------------------------- +END SUBROUTINE ioconf_startdate_simple +!- +!=== +!- +SUBROUTINE ioconf_startdate_ymds (year,month,day,sec) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL,INTENT(IN) :: sec +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!- + CALL ioconf_startdate_internal (julian_day,julian_sec) +!----------------------------------- +END SUBROUTINE ioconf_startdate_ymds +!- +!=== +!- +SUBROUTINE ioconf_startdate_internal (julian_day,julian_sec) +!--------------------------------------------------------------------- +! This subroutine allows to set the startdate for later +! use. It allows the applications to access the date directly from +! the timestep. In order to avoid any problems the start date will +! be locked and can not be changed once set. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: julian_day + REAL,INTENT(IN) :: julian_sec +!- + CHARACTER(len=70) :: str70a,str70b +!--------------------------------------------------------------------- + IF (.NOT.lock_startdate) THEN + start_day = julian_day + start_sec = julian_sec + lock_startdate = .TRUE. + ELSE + WRITE(str70a,'("The date you tried to set : ",f10.4)') & + & julian_day,julian_sec/one_day + WRITE(str70b, & + & '("The date which was already set in the calendar : ",f10.4)') & + & start_day+start_sec/one_day + CALL ipslerr (2,'ioconf_startdate', & + & 'The start date has already been set and you tried to change it', & + & str70a,str70b) + ENDIF +!--------------------------------------- +END SUBROUTINE ioconf_startdate_internal +!- +!=== +!- +SUBROUTINE ioget_calendar_str (str) +!--------------------------------------------------------------------- +!- This subroutine returns the name of the calendar used here. +!- Three options exist : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!- +!- This routine will lock the calendar. +!- You do not want it to change after your inquiry. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(OUT) :: str +!--------------------------------------------------------------------- + lock_one_year = .TRUE. +!- + str = calendar_used +!-------------------------------- +END SUBROUTINE ioget_calendar_str +!- +!=== +!- +SUBROUTINE ioget_calendar_real1 (long_year) +!--------------------------------------------------------------------- +!- This subroutine returns the name of the calendar used here. +!- Three options exist : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!- +!- This routine will lock the calendar. +!- You do not want it to change after your inquiry. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(OUT) :: long_year +!--------------------------------------------------------------------- + long_year = one_year + lock_one_year = .TRUE. +!---------------------------------- +END SUBROUTINE ioget_calendar_real1 +!- +!=== +!- +SUBROUTINE ioget_calendar_real2 (long_year,long_day) +!--------------------------------------------------------------------- +!- This subroutine returns the name of the calendar used here. +!- Three options exist : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!- +!- This routine will lock the calendar. +!- You do not want it to change after your inquiry. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(OUT) :: long_year,long_day +!--------------------------------------------------------------------- + long_year = one_year + long_day = one_day + lock_one_year = .TRUE. +!---------------------------------- +END SUBROUTINE ioget_calendar_real2 +!- +!=== +!- +INTEGER FUNCTION ioget_mon_len (year,month) +!!-------------------------------------------------------------------- +!! The "ioget_mon_len" function returns +!! the number of days in a "month" of a "year", +!! in the current calendar. +!! +!! INTEGER FUNCTION ioget_mon_len (year,month) +!! +!! INPUT +!! +!! (I) year : year +!! (I) month : month in the year (1 --> 12) +!! +!! OUTPUT +!! +!! (I) ioget_mon_len : number of days in the month +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month +!- + INTEGER :: ml +!--------------------------------------------------------------------- + IF ( (month >= 1).AND.(month <= 12) ) THEN + IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN +!---- "Gregorian" or "Julian" + ml = mon_len(month) + IF (month == 2) THEN + IF (ABS(one_year-365.2425) <= EPSILON(one_year) ) THEN +!-------- "Gregorian" + IF ( ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) & + .OR.(MOD(year,400) == 0) ) THEN + ml = ml+1 + ENDIF + ELSE +!-------- "Julian" + IF (MOD(year,4) == 0) THEN + ml = ml+1 + ENDIF + ENDIF + ENDIF + ioget_mon_len = ml + ELSE +!---- "No leap" or "All leap" or "Calendar with regular month" + ioget_mon_len = mon_len(month) + ENDIF + ELSE + CALL ipslerr (3,'ioget_mon_len', & + & 'The number of the month','must be between','1 and 12') + ENDIF +!------------------------- +END FUNCTION ioget_mon_len +!- +!=== +!- +INTEGER FUNCTION ioget_year_len (year) +!!-------------------------------------------------------------------- +!! The "ioget_year_len" function returns +!! the number of days in "year", in the current calendar. +!! +!! INTEGER FUNCTION ioget_year_len (year) +!! +!! INPUT +!! +!! (I) year : year +!! +!! OUTPUT +!! +!! (I) ioget_year_len : number of days in the year +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year +!- + INTEGER :: yl +!--------------------------------------------------------------------- + SELECT CASE(TRIM(calendar_used)) + CASE('gregorian') + yl = 365 + IF ( ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) & + .OR.(MOD(year,400) == 0) ) THEN + yl = yl+1 + ENDIF + CASE('julian') + yl = 365 + IF (MOD(year,4) == 0) THEN + yl = yl+1 + ENDIF + CASE DEFAULT + yl = NINT(one_year) + END SELECT + ioget_year_len = yl +!-------------------------- +END FUNCTION ioget_year_len +!- +!=== +!- +SUBROUTINE ioget_timestamp (string) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=30),INTENT(OUT) :: string +!- + INTEGER :: date_time(8) + CHARACTER(LEN=10) :: bigben(3) +!--------------------------------------------------------------------- + IF (INDEX(time_stamp,'XXXXXX') > 0) THEN + CALL DATE_AND_TIME (bigben(1),bigben(2),bigben(3),date_time) +!--- + WRITE(time_stamp, & + & "(I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,' GMT',a5)") & + & date_time(1),cal(date_time(2)),date_time(3),date_time(5), & + & date_time(6),date_time(7),bigben(3) + ENDIF +!- + string = time_stamp +!----------------------------- +END SUBROUTINE ioget_timestamp +!- +!=== +!- +SUBROUTINE time_add & + & (year_s,month_s,day_s,sec_s,sec_increment, & + & year_e,month_e,day_e,sec_e) +!--------------------------------------------------------------------- +!- This subroutine allows to increment a date by a number of seconds. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year_s,month_s,day_s + REAL,INTENT(IN) :: sec_s +!- +! Time in seconds to be added to the date +!- + REAL,INTENT(IN) :: sec_increment +!- + INTEGER,INTENT(OUT) :: year_e,month_e,day_e + REAL,INTENT(OUT) :: sec_e +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal & + & (year_s,month_s,day_s,sec_s,julian_day,julian_sec) +!- + julian_sec = julian_sec+sec_increment +!- + CALL ju2ymds_internal & + & (julian_day,julian_sec,year_e,month_e,day_e,sec_e) +!---------------------- +END SUBROUTINE time_add +!- +!=== +!- +SUBROUTINE time_diff & + & (year_s,month_s,day_s,sec_s,year_e,month_e,day_e,sec_e,sec_diff) +!--------------------------------------------------------------------- +!- This subroutine allows to determine the number of seconds +!- between two dates. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year_s,month_s,day_s + REAL,INTENT(IN) :: sec_s + INTEGER,INTENT(IN) :: year_e,month_e,day_e + REAL,INTENT(IN) :: sec_e +!- +! Time in seconds between the two dates +!- + REAL,INTENT(OUT) :: sec_diff +!- + INTEGER :: julian_day_s,julian_day_e,day_diff + REAL :: julian_sec_s,julian_sec_e +!--------------------------------------------------------------------- + CALL ymds2ju_internal & + & (year_s,month_s,day_s,sec_s,julian_day_s,julian_sec_s) + CALL ymds2ju_internal & + & (year_e,month_e,day_e,sec_e,julian_day_e,julian_sec_e) +!- + day_diff = julian_day_e-julian_day_s + sec_diff = julian_sec_e-julian_sec_s +!- + sec_diff = sec_diff+day_diff*one_day +!----------------------- +END SUBROUTINE time_diff +!- +!=== +!- +END MODULE calendar diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/a7/a765319c4ec26966ecd4f1f5c9181b4d2afce74b.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/a7/a765319c4ec26966ecd4f1f5c9181b4d2afce74b.svn-base new file mode 100644 index 0000000..d32fc9d --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/a7/a765319c4ec26966ecd4f1f5c9181b4d2afce74b.svn-base @@ -0,0 +1,110 @@ +#!/bin/ksh +# +#$Id$ +# +# This software is governed by the CeCILL license +# See IOIPSL/IOIPSL_License_CeCILL.txt +#--------------------------------------------------------------------- +# @(#)Rebuild IOIPSL domains +#--------------------------------------------------------------------- +function rebuild_Usage +{ +print - " +\"${b_n}\" + rebuild a model_file from several input files. +Each input file contains the model_data for a domain. + +Usage : + ${b_n} [-h] + ${b_n} [-v level] [-f] -o output_file_name input_file_names + +Options : + -h : help + -v O/1/2/3 : verbose mode (verbosity increasing with level) + -f : executing mode + (execute the program even if the number of input files + is not equal to the total number of domains) +" +} +#- +#set -xv +#- +# Extract the calling sequence of the script (d_n/b_n) +#- +d_n=${0%/*}; b_n=${0##*/}; +#- +# Retrieving the options +#- +r_v='0'; r_f='noforce'; r_o=""; +while getopts :hv:fo: V + do + case $V in + (h) rebuild_Usage; exit 0;; + (v) r_v=${OPTARG};; + (f) r_f='force';; + (o) r_o=${OPTARG};; + (:) print -u2 "${b_n} : missing value for option $OPTARG"; exit 2;; + (\?) print -u2 "${b_n} : option $OPTARG not supported"; exit 2;; + esac + done +shift $(($OPTIND-1)); +#- +# Validate the -v option +#- +case ${r_v} in + ( 0 | 1 | 2 | 3 );; + ("") r_v='0';; + (*) + print -u2 "${b_n} :"; + print -u2 "Invalid verbosity level requested : ${r_v}"; + print -u2 "(must be 0, 1, 2 or 3)"; + exit 1;; +esac +#- +# Validate the number of arguments +#- +[[ ${#} < 1 ]] && \ + { + print -u2 "${b_n} : Too few arguments have been specified. (Use -h)"; + exit 3; + } +#- +# Check for the output file name +#- +[[ -z ${r_o} ]] && \ + { + r_o='rebuilt_file.nc'; + print -u2 - " + ${b_n} : output_file_name not specified. (Use -h) + rebuilt_file.nc should be created." + } +#- +# Validate the names of the input files +#- +for i in $*; + do + [[ ! -f ${i} ]] && { echo "${i} unreachable ..."; exit 3;} + done +#- +# Create the information file for the program +#- +echo ${r_v} > tmp.$$; +echo ${r_f} >> tmp.$$; +echo $((${#}+1)) >> tmp.$$; +for i in $*; + do echo ${i} >> tmp.$$; + done +echo ${r_o} >> tmp.$$; +#- +# Create the output file +#- +${d_n}/flio_rbld.exe < tmp.$$ +r_c=$? +#- +# Clear +#- +rm -f tmp.$$ +#- +# End +#- +exit ${r_c}; diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/a8/a8cc03105f3ec4e7aa120a6dd238046e45549e41.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/a8/a8cc03105f3ec4e7aa120a6dd238046e45549e41.svn-base new file mode 100644 index 0000000..426c9c8 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/a8/a8cc03105f3ec4e7aa120a6dd238046e45549e41.svn-base @@ -0,0 +1,185 @@ +MODULE stringop +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +CONTAINS +!= +SUBROUTINE cmpblank (str) +!--------------------------------------------------------------------- +!- Compact blanks +!--------------------------------------------------------------------- + CHARACTER(LEN=*),INTENT(inout) :: str +!- + INTEGER :: lcc,ipb +!--------------------------------------------------------------------- + lcc = LEN_TRIM(str) + ipb = 1 + DO + IF (ipb >= lcc) EXIT + IF (str(ipb:ipb+1) == ' ') THEN + str(ipb+1:) = str(ipb+2:lcc) + lcc = lcc-1 + ELSE + ipb = ipb+1 + ENDIF + ENDDO +!---------------------- +END SUBROUTINE cmpblank +!=== +INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds number of occurences of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!- + INTEGER :: ipos,indx +!--------------------------------------------------------------------- + cntpos = 0 + ipos = 1 + DO + indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) + IF (indx > 0) THEN + cntpos = cntpos+1 + ipos = ipos+indx+l_r-1 + ELSE + EXIT + ENDIF + ENDDO +!------------------ +END FUNCTION cntpos +!=== +INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds position of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!--------------------------------------------------------------------- + findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) + IF (findpos == 0) findpos=-1 +!------------------- +END FUNCTION findpos +!=== +SUBROUTINE find_str (str_tab,str,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a string in a table +!--------------------------------------------------------------------- +!- INPUT +!- str_tab : Table of strings +!- str : Target we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab + CHARACTER(LEN=*),INTENT(in) :: str + INTEGER,INTENT(out) :: pos +!- + INTEGER :: nb_str,i +!--------------------------------------------------------------------- + pos = -1 + nb_str=SIZE(str_tab) + IF ( nb_str > 0 ) THEN + DO i=1,nb_str + IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN + pos = i + EXIT + ENDIF + ENDDO + ENDIF +!---------------------- +END SUBROUTINE find_str +!=== +SUBROUTINE nocomma (str) +!--------------------------------------------------------------------- +!- Replace commas with blanks +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + IF (str(i:i) == ',') str(i:i) = ' ' + ENDDO +!--------------------- +END SUBROUTINE nocomma +!=== +SUBROUTINE strlowercase (str) +!--------------------------------------------------------------------- +!- Converts a string into lowercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 65).AND.(ic <= 90) ) str(i:i) = ACHAR(ic+32) + ENDDO +!-------------------------- +END SUBROUTINE strlowercase +!=== +SUBROUTINE struppercase (str) +!--------------------------------------------------------------------- +!- Converts a string into uppercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 97).AND.(ic <= 122) ) str(i:i) = ACHAR(ic-32) + ENDDO +!-------------------------- +END SUBROUTINE struppercase +!=== +SUBROUTINE str_xfw (c_string,c_word,l_ok) +!--------------------------------------------------------------------- +!- Given a character string "c_string", of arbitrary length, +!- returns a logical flag "l_ok" if a word is found in it, +!- the first word "c_word" if found and the new string "c_string" +!- without the first word "c_word" +!--------------------------------------------------------------------- + CHARACTER(LEN=*),INTENT(INOUT) :: c_string + CHARACTER(LEN=*),INTENT(OUT) :: c_word + LOGICAL,INTENT(OUT) :: l_ok +!- + INTEGER :: i_b,i_e +!--------------------------------------------------------------------- + l_ok = (LEN_TRIM(c_string) > 0) + IF (l_ok) THEN + i_b = VERIFY(c_string,' ') + i_e = INDEX(c_string(i_b:),' ') + IF (i_e == 0) THEN + c_word = c_string(i_b:) + c_string = "" + ELSE + c_word = c_string(i_b:i_b+i_e-2) + c_string = ADJUSTL(c_string(i_b+i_e-1:)) + ENDIF + ENDIF +!--------------------- +END SUBROUTINE str_xfw +!=== +!------------------ +END MODULE stringop diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/b0/b070eff68b1145278642578898e5d05b4d5640b6.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/b0/b070eff68b1145278642578898e5d05b4d5640b6.svn-base new file mode 100644 index 0000000..f026ba0 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/b0/b070eff68b1145278642578898e5d05b4d5640b6.svn-base @@ -0,0 +1,793 @@ +PROGRAM fparser +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt + + USE stringop + + IMPLICIT NONE + ! + ! + ! Parses the code to create the Config.in Config.default and Config.help + ! which are used by the tk shell. + ! + ! + INTEGER nbkeymax, nbhelpmax, nbcasemax, nbsourmax, nbelmax + PARAMETER (nbkeymax=100, nbhelpmax=50, nbcasemax=50, nbsourmax=20,nbelmax=nbhelpmax+10) + INTEGER nbfilesmax + PARAMETER (nbfilesmax=150) + + ! + CHARACTER*120 :: configs(nbkeymax,nbelmax) + CHARACTER*120 :: tmp_help, tmp_key, tmp_desc, tmp_def + INTEGER :: keylen(nbkeymax), nbkeys + INTEGER :: key_pos(nbkeymax), help_pos(nbkeymax,2), def_pos(nbkeymax,2) + INTEGER :: des_pos(nbkeymax), IF_pos(nbkeymax) + CHARACTER*6 TYPE_op(nbkeymax) + ! + CHARACTER*120 :: def_out(nbkeymax, nbhelpmax) + INTEGER :: nbdef_out(nbkeymax) + ! + CHARACTER*120 :: tke + ! + CHARACTER*2 :: nbstr + ! + CHARACTER*80 :: files(nbfilesmax), source(nbsourmax), filetmp + CHARACTER*80 :: tmp, main_name + CHARACTER*120 :: keycase(nbcasemax), tmp_CASE + INTEGER :: nbcase, ii, find, nbsource + LOGICAL :: next_source, next_name, last_or + + LOGICAL :: is_main, cont + + CHARACTER*1 :: backslash, simplequote, doublequote + + INTEGER :: ia, iread, iret, IFF, ih, nb_line, iv, id + INTEGER :: ind_space, ind_comma, ind_USE + INTEGER :: nbfiles, nb_key, nb_key_file + ! + INTEGER, EXTERNAL :: iargc, getarg + ! + ! + next_source = .FALSE. + next_name = .FALSE. + is_main = .FALSE. + nbsource = 0 + nbfiles = 0 + main_name = 'IPSL' + ! + backslash = ACHAR(92) + simplequote = ACHAR(39) + doublequote = ACHAR(34) + ! + ! + ! + ! Analyse command line + ! + ! + ! Get the number of arguments, that is the options and the + ! files to be parsed. + ! + ! + + iread = iargc() + ! + DO ia=1,iread + ! + iret = getarg(ia,tmp) + ! + IF (next_source) THEN + + nbsource = nbsource + 1 + IF ( nbsource .GT. nbsourmax) THEN + WRITE(*,*) 'Too many files to source in the arguments.' + WRITE(*,*) 'Increase nbsourmax' + STOP + ELSE + source(nbsource) = tmp(1:LEN_TRIM(tmp)) + ENDIF + next_source = .FALSE. + + ELSE IF (next_name) THEN + main_name = tmp(1:LEN_TRIM(tmp)) + next_name = .FALSE. + + ELSE + ! + IF ( INDEX(tmp,'-m') .GT. 0) THEN + is_main = .TRUE. + ELSE IF ( INDEX(tmp,'-n') .GT. 0) THEN + next_name = .TRUE. + ELSE IF ( INDEX(tmp,'-s') .GT. 0) THEN + next_source = .TRUE. + ELSE IF ( INDEX(tmp,'-h') .GT. 0) THEN + WRITE(*,*) 'USAGE : Fparse [-name NAME] ' + WRITE(*,*) ' [-source file_to_source]' + WRITE(*,*) ' [-main] FORTAN_files' + ELSE + nbfiles = nbfiles + 1 + IF ( nbfiles .GT. nbfilesmax) THEN + WRITE(*,*) 'Too many files to include in & + & the arguments.' + WRITE(*,*) 'Increase nbfilesmax' + STOP + ELSE + files(nbfiles) = tmp(1:LEN_TRIM(tmp)) + ENDIF + ENDIF + + ENDIF + + ENDDO + ! + IF ( nbfiles .LT. 1 ) THEN + WRITE(*,*) 'No files provided' + STOP + ENDIF + ! + ! + ! 1.0 Read files and extract the lines which we need + ! + ! + nb_key = 0 + ! + DO IFF=1,nbfiles + ! + filetmp = files(IFF) + CALL READ_from_file(filetmp, nbkeymax, nbelmax, configs, nb_key, keylen) + ! + ENDDO + ! + ! 2.0 Scan the information we have extracted from the file for the elements we need + ! + ! + CALL analyse_configs(nbkeymax, nb_key, nbelmax, keylen, configs, key_pos, help_pos, def_pos, des_pos, IF_pos, TYPE_op) + ! + ! + ! 3.0 Prepare the default values to put them in an array + ! + ! + DO ia = 1,nb_key + ! + ! 3.1 Go to blank delimited lines + ! + nbdef_out(ia) = 0 + ! + DO ii=def_pos(ia,1), def_pos(ia,2) + ! + tmp_help = configs(ia,ii) + ind_comma = INDEX(tmp_help(1:len_TRIM(tmp_help)),',') + DO WHILE (ind_comma .GT. 0) + tmp_help(ind_comma:ind_comma) = ' ' + ind_comma = INDEX(tmp_help,',') + ENDDO + CALL cmpblank(tmp_help) + configs(ia,ii) = tmp_help + ! + ! 3.2 extract the values + ! + tmp_help = TRIM(ADJUSTL(configs(ia,ii))) + ind_space= INDEX(tmp_help(1:LEN_TRIM(tmp_help)),' ') + ! Get the first one (there is no space in between) + IF ( ind_space .EQ. 0) THEN + nbdef_out(ia) = nbdef_out(ia) + 1 + def_out(ia, nbdef_out(ia)) = tmp_help(1:LEN_TRIM(tmp_help)) + ELSE + ! Get all those which are before spaces + DO WHILE (ind_space .GT. 0) + nbdef_out(ia) = nbdef_out(ia) + 1 + def_out(ia, nbdef_out(ia)) = tmp_help(1:ind_space) + tmp_help = ADJUSTL(tmp_help(ind_space+1:LEN_TRIM(tmp_help))) + ind_space= INDEX(tmp_help(1:LEN_TRIM(tmp_help)),' ') + ENDDO + ! Get the last one which does not have a space behind + IF ( LEN_TRIM(tmp_help) .GT. 0) THEN + nbdef_out(ia) = nbdef_out(ia) + 1 + def_out(ia, nbdef_out(ia)) = tmp_help(1:LEN_TRIM(tmp_help)) + ENDIF + ! + ENDIF + ENDDO + ! + ENDDO + ! + ! + ! + ! 4.0 OPEN Config.in Defaults and Help files + ! + ! + OPEN (16, FILE='Config.in') + OPEN (17, FILE='Config.help') + OPEN (18, FILE='Config.defaults') + ! + ! Some explantation + ! + DO IFF=16,18 + WRITE(IFF,'(1a)') '# ' + WRITE(IFF,'(1a)') '# File created by Fparser, DO NOT EDIT' + WRITE(IFF,'(2a)') '# ', main_name(1:LEN_TRIM(main_name)) + WRITE(IFF,'(1a)') '# ' + WRITE(IFF,'(1a)') '# ' + ENDDO + ! + WRITE(17,'(2a)') '# Format of this file: description<nl>', & + & ' variable<nl>helptext<nl><nl>.' + WRITE(17,'(2a)') '# If the question being documented is of', & + & ' type "choice", we list' + WRITE(17,'(2a)') '# only the first occurring config variable.', & + & ' The help texts' + WRITE(17,'(2a)') '# must not contain empty lines. No variable', & + & ' should occur twice; if it' + WRITE(17,'(2a)') '# does, only the first occurrence will be', & + & ' used by Configure. The lines' + WRITE(17,'(2a)') '# in a help text should be indented two', & + & ' positions. Lines starting with' + WRITE(17,'(2a)') '# "#" are ignored. To be nice to menuconfig,', & + & ' limit your lines to 70' + WRITE(17,'(2a)') '# characters. Use emacs" kfill.el to edit', & + & ' this file or you lose.' + WRITE(17,'(2a)') '#' + ! + IF ( is_main ) THEN + WRITE(16,'(3a)') 'mainmenu_name "Configuration of model ', & + & main_name(1:LEN_TRIM(main_name)), '"' + WRITE(16,'(1a)') '# ' + ENDIF + ! + WRITE(16,'(1a)') 'mainmenu_option next_comment' + WRITE(16,'(3a)') 'comment "', main_name(1:LEN_TRIM(main_name)), '"' + WRITE(16,'(1a)') '# ' + ! + ! 5.0 Loop through the KEYWORDS to prepare the output + ! + DO IFF =1,nb_key + ! + ! Config.in file + ! + + ! + ! Is it a conditional option ? + ! + IF ( IF_pos(IFF) .GE. 0) THEN + tmp_help = configs(IFF,IF_pos(IFF)) + ! + IF ( (index(tmp_help,'||') .LE. 0) .AND. (index(tmp_help,'&&') .LE. 0) ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') 'if [ "$', tmp_help(2:LEN_TRIM(tmp_help)), '" = "n" ]; then' + ELSE + WRITE(16,'(3a)') 'if [ "$', tmp_help(1:LEN_TRIM(tmp_help)), '" = "y" ]; then' + ENDIF + ELSE + ! + last_or = .TRUE. + nbcase = 0 + ! + DO WHILE( INDEX(tmp_help,'||') .GT. 0) + ii = INDEX(tmp_help,'||') + nbcase = nbcase + 1 + if ( nbcase .EQ. 1 ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') 'if [ "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') 'if [ "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ELSE + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-o "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') '-o "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ENDIF + tmp_help = TRIM(ADJUSTL(tmp_help(ii+2:LEN_TRIM(tmp_help)))) + ENDDO + ! + DO WHILE( INDEX(tmp_help,'&&') .GT. 0) + ii = INDEX(tmp_help,'&&') + nbcase = nbcase + 1 + if ( nbcase .EQ. 1 ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') 'if [ "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') 'if [ "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ELSE + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-a "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') '-a "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ENDIF + tmp_help = TRIM(ADJUSTL(tmp_help(ii+2:LEN_TRIM(tmp_help)))) + last_or = .FALSE. + ENDDO + ! + IF ( last_or ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-o "$', tmp_help(2:LEN_TRIM(tmp_help)), '" = "n" ]; then' + ELSE + WRITE(16,'(3a)') '-o "$', tmp_help(1:LEN_TRIM(tmp_help)), '" = "y" ]; then' + ENDIF + ELSE + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-a "$', tmp_help(2:LEN_TRIM(tmp_help)), '" = "n" ]; then' + ELSE + WRITE(16,'(3a)') '-a "$', tmp_help(1:LEN_TRIM(tmp_help)), '" = "y" ]; then' + ENDIF + ENDIF + ENDIF + WRITE(16,'(1a)') ' ' + ENDIF + ! + ! Extract the information from configs + ! + DO iv = 1,nbdef_out(IFF) + + IF (nbdef_out(IFF) .EQ. 1) THEN + tmp_key = configs(IFF,key_pos(IFF)) + tmp_desc = configs(IFF,des_pos(IFF)) + tmp_def = def_out(IFF,iv) + ELSE + tmp_key = configs(IFF,key_pos(IFF)) + WRITE(nbstr,'(I2.2)') iv + tmp_key = tmp_key(1:LEN_TRIM(tmp_key))//'__'//nbstr + tmp_desc = configs(IFF,des_pos(IFF)) + IF ( iv .EQ. 1) THEN + tmp_desc = tmp_desc(1:LEN_TRIM(tmp_desc))//' (Vector)' + ELSE + tmp_desc = 'Cont... '//tmp_key(1:LEN_TRIM(tmp_key)) + ENDIF + tmp_def = def_out(IFF,iv) + ENDIF + ! + ! + ! + IF (INDEX(TYPE_op(IFF),'bool') .GT. 0) THEN + ! + WRITE(16,'(4a)') 'bool "', tmp_desc(1:LEN_TRIM(tmp_desc)), & + & '" ',tmp_key(1:LEN_TRIM(tmp_key)) + ! + ELSE IF (INDEX(TYPE_op(IFF),'hex') .GT. 0) THEN + ! + WRITE(16,'(6a)') 'hex "', tmp_desc(1:LEN_TRIM(tmp_desc)) & + & ,'" ',tmp_key(1:LEN_TRIM(tmp_key)) & + & ,' ',tmp_def(1:LEN_TRIM(tmp_def)) + ! + ELSE IF (INDEX(TYPE_op(IFF),'choice') .GT. 0) THEN + ! + ! Get number of options + ! + nbcase = 0 + DO WHILE( INDEX(tmp_key,'||') .GT. 0) + ii = INDEX(tmp_key,'||') + nbcase = nbcase + 1 + keycase(nbcase) = tmp_key(1:ii-1) + tmp_key=tmp_key(ii+2:LEN_TRIM(tmp_key)) + ENDDO + nbcase = nbcase + 1 + keycase(nbcase) = tmp_key(1:LEN_TRIM(tmp_key)) + + WRITE(16,'(4a)') "choice '", tmp_desc(1:LEN_TRIM(tmp_desc))," '",backslash + ! + ! List options + ! + tmp_CASE = keycase(1) + WRITE(16,'(5a)') ' "', tmp_CASE(1:LEN_TRIM(tmp_CASE)), " "& + &,tmp_CASE(1:LEN_TRIM(tmp_CASE)), backslash + ! + DO ii=2,nbcase-1 + tmp_CASE = keycase(ii) + WRITE(16,'(5a)') ' ', tmp_CASE(1:LEN_TRIM(tmp_CASE)), ' ',& + & tmp_CASE(1:LEN_TRIM(tmp_CASE)), backslash + ENDDO + ! + tmp_CASE = keycase(nbcase) + WRITE(16,'(6a)') ' ', & + & tmp_CASE(1:LEN_TRIM(tmp_CASE)), & + & ' ', tmp_CASE(1:LEN_TRIM(tmp_CASE)), & + & '" ',tmp_def(1:LEN_TRIM(tmp_def)) + ! + ELSE + WRITE(*,'(2a)') 'Uniplemented operation : ', TYPE_op(IFF) + STOP + ENDIF + ! + ! Config.help file + ! + tmp_key = configs(IFF,key_pos(IFF)) + IF (INDEX(TYPE_op(IFF),'choice') .GT. 0) THEN + ii = INDEX(tmp_key,'||')-1 + ELSE + ii = LEN_TRIM(tmp_key) + ENDIF + + IF ( nbdef_out(IFF) .GT. 1) THEN + WRITE(17,'(1a)') tmp_desc(1:LEN_TRIM(tmp_desc)) + WRITE(nbstr,'(I2.2)') iv + tke = tmp_key(1:ii)//'__'//nbstr + WRITE(17,'(1a)') tke(1:LEN_TRIM(tke)) + WRITE(17,'(1a)') ' (Vector)' + ELSE + WRITE(17,'(1a)') tmp_desc(1:LEN_TRIM(tmp_desc)) + WRITE(17,'(1a)') tmp_key(1:ii) + ENDIF + ! + DO ih=help_pos(IFF,1),help_pos(IFF,2) + tmp_help = configs(IFF,ih) + WRITE(17,'(" ",1a)') tmp_help(1:LEN_TRIM(tmp_help)) + ENDDO + ! + ! Config.default file + ! + IF (INDEX(TYPE_op(IFF),'choice') .GT. 0) THEN + + WRITE(18,'(2a)') tmp_def(1:LEN_TRIM(tmp_def)),'=y' + + ELSE + + WRITE(18,'(3a)') tmp_key(1:LEN_TRIM(tmp_key)),'=', & + & tmp_def(1:LEN_TRIM(tmp_def)) + + ENDIF + ! + ! Add some empty line to all files + ! + WRITE(16,'(1a)') ' ' + WRITE(17,'(1a)') ' ' + WRITE(17,'(1a)') ' ' + ENDDO + ! + ! + ! Close the IF if needed + ! + + IF ( IF_pos(IFF) .GT. 0) THEN + WRITE(16,'(1a)') 'fi' + WRITE(16,'(1a)') ' ' + ENDIF + + ! + ENDDO + ! + WRITE(16,'(1a)') 'endmenu' + WRITE(16,'(1a)') ' ' + IF ( nbsource .GT. 0) THEN + DO ih=1,nbsource + tmp = source(ih) + WRITE(16,'(1a)') ' ' + WRITE(16,'(3a)') 'source ',tmp(1:LEN_TRIM(tmp)), & + & '/Config.in' + ENDDO + ENDIF + ! + ! + CLOSE(16) + CLOSE(17) + CLOSE(18) + ! + ! + ! + STOP + +END PROGRAM fparser +! +! +!========================================================== +! +! +SUBROUTINE READ_from_file(file, nbkeymax, nbelmax, configs, nbitems, itemlen) + ! + USE stringop + ! + IMPLICIT NONE + ! + ! + ! This routine reads the file and adds the config info it finds to the configs array. + ! Thus the nbitems is an imput variable as it can be increased as we go through the files. + ! + ! + CHARACTER*(*) :: file + INTEGER :: nbkeymax, nbelmax + CHARACTER*120 :: configs(nbkeymax, nbelmax) + INTEGER :: nbitems, itemlen(nbkeymax) + ! + INTEGER :: conf_pos, ip + CHARACTER*250 line + LOGICAL :: cont, conf_END + ! + cont = .TRUE. + conf_END = .TRUE. + ! + OPEN (12, file=file) + ! + ! 1.0 Loop over all the lines of a given file to extract all the configuration line + ! + DO WHILE (cont) + READ(12,'(a)',END=9999) line + ! + ! 1.0 A configuration line is detected by the line below. + ! + IF ( INDEX(line,'Config') .EQ. 1 .OR. INDEX(line,'!'//'Config') .GE. 1 ) THEN + ! + IF ( conf_END ) THEN + nbitems = nbitems + 1 + IF ( nbitems .GT. nbkeymax) THEN + WRITE(*,*) 'read_from_file : The number of keys in the input array is too small for this file' + STOP + ENDIF + itemlen(nbitems) = 0 + conf_END = .FALSE. + ENDIF + ! + itemlen(nbitems) = itemlen(nbitems) + 1 + IF ( itemlen(nbitems) .GT. nbelmax ) THEN + WRITE(*,*) 'read_from_file : The number of elements per key in the input array is too small' + STOP + ENDIF + ! + ! The detected line is shaved ! + ! + IF ( INDEX(line,'Config') .EQ. 1) THEN + conf_pos = 7 + ELSE + conf_pos = INDEX(line,'!'//'Config') +7 + ENDIF + line = line(conf_pos:LEN_TRIM(line)) + line = TRIM(ADJUSTL(line)) + CALL cmpblank(line) + ! + configs(nbitems,itemlen(nbitems)) = line + ! + ELSE + ! + ! Look for the end of a configuration structure. + ! It is determined by a call to the getin subroutine + ! + CALL strlowercase(line) + CALL cmpblank(line) + ip = INDEX(line,' (') + DO WHILE (ip .GT. 0) + line = line(1:ip-1)//line(ip+1:LEN_TRIM(line)) + ip = INDEX(line,' (') + ENDDO + IF ( INDEX(line, 'call getin(') .GT. 0 .OR. INDEX(line, 'call setvar(') .GT. 0) THEN + conf_END = .TRUE. + ENDIF + ! + ENDIF + ! + cont = .TRUE. + GOTO 8888 +9999 cont = .FALSE. +8888 CONTINUE + + ENDDO + ! + CLOSE(12) + ! + END SUBROUTINE READ_from_file + ! + !========================================================== + ! + ! + SUBROUTINE analyse_configs(nbkmax, nb_key, nbelmax, keylen, configs, key_pos, help_pos, def_pos, des_pos, IF_pos, TYPE_op) + ! + USE stringop + ! + IMPLICIT NONE + ! + ! + ! This subroutine will localize the KEYWORDS in the configs array + ! and extract all their arguments. For the moment 5 arguments are recognized : + ! KEY : The keyword by which the all is identified + ! HELP : This identifies the help text + ! DEF : The default value of for this KEYWORD + ! DESC : A short description, not more than one line + ! IF : Specifies the other Keyword it depend on. This is a nice features for the menus as it can hide + ! things we do not need + ! + ! The DEF and HELP keywords can be multi line + ! + INTEGER :: nbkmax, nb_key, nbelmax + INTEGER :: keylen(nbkmax) + INTEGER :: key_pos(nbkmax), help_pos(nbkmax,2), def_pos(nbkmax,2), des_pos(nbkmax), IF_pos(nbkmax) + CHARACTER*120 :: configs(nbkmax,nbelmax) + CHARACTER*6 :: TYPE_op(nbkmax) + ! + ! This is the number of arguments we need to find an end for and the total number of arguments we can have. + ! Thus these parameters needs to be updated when the list of arguments to the routine is changed + ! + INTEGER, PARAMETER :: toendlen=2, indexlen=5 + ! + INTEGER :: toend(toendlen), foundend(toendlen), kindex(indexlen) + INTEGER :: ik, il, ieq + CHARACTER*120 :: tmp_str, tmp_str2 + ! + ! + key_pos(1:nb_key)=-1 + help_pos(1:nb_key,1:2)=-1 + def_pos(1:nb_key,1:2)=-1 + des_pos(1:nb_key)=-1 + IF_pos(1:nb_key)=-1 + TYPE_op(1:nb_key)='hex' + ! + DO ik=1,nb_key + ! + ! + DO il=1,keylen(ik) + ! + ieq = INDEX(configs(ik,il),'=') + tmp_str = configs(ik,il) + tmp_str = tmp_str(1:ieq) + CALL struppercase(tmp_str) + ! + ! Decide if this is a reserved name and where it fits + ! + ! At the same time we clean up the configs array + ! + IF ( INDEX(tmp_str,'KEY') .GT. 0) THEN + IF ( key_pos(ik) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a KEYWORD, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + key_pos(ik) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ! + ! Here we have to check that we are not in an 'choice' case + ! + IF ( INDEX(tmp_str2,'||') .GT. 0) THEN + TYPE_op(ik) = 'choice' + ENDIF + ! + ENDIF + ! + IF ( INDEX(tmp_str,'DEF') .GT. 0) THEN + IF ( def_pos(ik,1) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a DEF, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + def_pos(ik,1) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + tmp_str2 = TRIM(ADJUSTL(tmp_str2)) + configs(ik,il) = tmp_str2 + ! + ! Here we can check if we have a boolean operation + ! We also wish to standardise the value of booleans + ! + CALL struppercase(tmp_str2) + IF (INDEX(tmp_str2,'Y') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'T') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'YES') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 3 .OR.& + & INDEX(tmp_str2,'TRUE') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 4 .OR.& + & INDEX(tmp_str2,'.TRUE.') .EQ. 1) THEN + configs(ik,il) = 'y' + TYPE_op(ik) = 'bool' + ENDIF + ! + IF (INDEX(tmp_str2,'N') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'F') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'NO') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 2 .OR.& + & INDEX(tmp_str2,'FALSE') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 5 .OR.& + & INDEX(tmp_str2,'.FALSE.') .EQ. 1) THEN + configs(ik,il) = 'n' + TYPE_op(ik) = 'bool' + ENDIF + ! + ! Here we check if we have a default behavior and put a standard name + ! + IF (INDEX(tmp_str2,'DEF') .EQ. 1 .OR. INDEX(tmp_str2,'NONE') .EQ. 1) THEN + configs(ik,il) = 'default' + ENDIF + ! + ENDIF + ! + IF ( INDEX(tmp_str,'DESC') .GT. 0) THEN + IF ( des_pos(ik) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a DESC, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + des_pos(ik) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ENDIF + ! + IF ( INDEX(tmp_str,'IF') .GT. 0) THEN + IF ( IF_pos(ik) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a IF, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + IF_pos(ik) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ENDIF + ! + IF ( INDEX(tmp_str,'HELP') .GT. 0) THEN + help_pos(ik,1) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ENDIF + ! + ENDDO + ! + ! Check if we not missing some important informations as for instance + ! + ! THE KEYWORD + ! + IF ( key_pos(ik) .LT. 1) THEN + WRITE(*,*) 'analyse_configs : Could not find a keyword in the following entry :' + DO il=1,keylen(ik) + WRITE(*,'(a70)') configs(ik,il) + ENDDO + STOP + ENDIF + ! + ! THE DEFAULT VALUE + ! + IF ( def_pos(ik,1) .LT. 1) THEN + WRITE(*,*) 'analyse_configs : Could not find a default value in the following entry :' + DO il=1,keylen(ik) + WRITE(*,'(a70)') configs(ik,il) + ENDDO + STOP + ENDIF + ! + ! Get the end of all the multi line arguments + ! + toend(1) = MAX(def_pos(ik,1),1) + toend(2) = MAX(help_pos(ik,1),1) + foundend(:) = keylen(ik) + kindex(1) = MAX(key_pos(ik),1) + kindex(2) = MAX(des_pos(ik),1) + kindex(3) = MAX(def_pos(ik,1),1) + kindex(4) = MAX(IF_pos(ik),1) + kindex(5) = MAX(help_pos(ik,1),1) + CALL find_ends(toendlen, toend, indexlen, kindex, foundend) + def_pos(ik,2) = foundend(1) + help_pos(ik,2) = foundend(2) + ! + ENDDO + ! + END SUBROUTINE analyse_configs + ! + SUBROUTINE find_ends(toendlen, toend, indexlen, kindex, foundend) + ! + IMPLICIT NONE + ! + ! + ! We find the end of the text for all the elements in the key which are multi line + ! This subroutine aims at providing a flexible way to determine this so that other + ! elements in the Keyword can be multi line. For the moment it is only the Help and Ded + ! which are allowed to be multi line. + ! + ! Foundend need to be initialized to the maximum value of the elements + ! + ! + INTEGER :: toendlen, toend(toendlen), indexlen, kindex(indexlen), foundend(toendlen) + ! + INTEGER :: whmin(1), ie, ii + ! + DO ie=1,toendlen + ! + whmin = MINLOC(toend(1:toendlen)) + ! + DO ii=1,indexlen + IF ( kindex(ii) .GT. toend(whmin(1)) .AND. foundend(whmin(1)) .GE. kindex(ii)) THEN + foundend(whmin(1)) = kindex(ii)-1 + toend(whmin(1)) = 100000 + ENDIF + ENDDO + ! + ENDDO + ! + END SUBROUTINE find_ends diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/b4/b40da4fa4c5bf62dfc7517fc38e9bdaceec17adc.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/b4/b40da4fa4c5bf62dfc7517fc38e9bdaceec17adc.svn-base new file mode 100644 index 0000000..784fc1a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/b4/b40da4fa4c5bf62dfc7517fc38e9bdaceec17adc.svn-base @@ -0,0 +1,36 @@ +The following licence information concerns ONLY the IOIPSL directory +==================================================================== + +Copyright (C) Institut Pierre Simon Laplace : IPSL + +This software is composed by a set of subroutines working as an +interface between climate models and NETCDF files following CF +convention. Library sources, examples of use and tools based on +IOIPSL are provided. This library requires NetCDF library : +http://www.unidata.ucar.edu/software/netcdf/ + +This software is governed by the CeCILL license under French law and +abiding by the rules of distribution of free software. You can use, +modify and/or redistribute the software under the terms of the CeCILL +license as circulated by CEA, CNRS and INRIA at the following URL +"http://www.cecill.info". + +As a counterpart to the access to the source code and rights to copy, +modify and redistribute granted by the license, users are provided only +with a limited warranty and the software's author, the holder of the +economic rights, and the successive licensors have only limited +liability. + +In this respect, the user's attention is drawn to the risks associated +with loading, using, modifying and/or developing or reproducing the +software by the user in light of its specific status of free software, +that may mean that it is complicated to manipulate, and that also +therefore means that it is reserved for developers and experienced +professionals having in-depth computer knowledge. Users are therefore +encouraged to load and test the software's suitability as regards their +requirements in conditions enabling the security of their systems and/or +data to be ensured and, more generally, to use and operate it in the +same conditions as regards security. + +The fact that you are presently reading this means that you have had +knowledge of the CeCILL license and that you accept its terms. diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/cc/ccc7d41683cdbc11558715fb7518b7e62dd5ffda.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/cc/ccc7d41683cdbc11558715fb7518b7e62dd5ffda.svn-base new file mode 100644 index 0000000..780d1a2 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/cc/ccc7d41683cdbc11558715fb7518b7e62dd5ffda.svn-base @@ -0,0 +1,1939 @@ +MODULE flincom +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- + USE netcdf +!- + USE calendar, ONLY : ju2ymds, ymds2ju, ioconf_calendar + USE errioipsl, ONLY : histerr + USE stringop, ONLY : strlowercase +!- + IMPLICIT NONE +!- + PRIVATE + PUBLIC :: flinput, flincre, flinget, flinclo, & + flinopen, flininfo, flininspect, flinquery_var +!- + INTERFACE flinopen +!--------------------------------------------------------------------- +!- The "flinopen" routines will open an input file +!- +!- INPUT +!- +!- filename : Name of the netCDF file to be opened +!- +!- iideb : index i for zoom ! +!- iilen : length of zoom ! for +!- jjdeb : index j for zoom ! zoom +!- jjlen : length of zoom ! +!- +!- do_test : A flag that enables the testing of the content +!- of the file against the input from the model +!- +!- INPUT if do_test=TRUE OUTPUT else +!- +!- iim : size in the x direction in the file (longitude) +!- jjm : size in the y direction +!- llm : number of levels +!- (llm = 0 means no axis to be expected) +!- lon : array of (iilen,jjlen) (zoom), or (iim,jjm) (no zoom), +!- that contains the longitude of each point +!- lat : same for latitude +!- lev : An array of llm for the latitude +!- +!- WARNING : +!- In the case of do_test=FALSE it is for the user to check +!- that the dimensions of lon lat and lev are correct when passed to +!- flinopen. This can be done after the call when iim and jjm have +!- been retrieved from the netCDF file. In F90 this problem will +!- be solved with an internal assign +!- IF iim, jjm, llm or ttm are parameters in the calling program and +!- you use the option do_test=FALSE it will create a segmentation fault +!- +!- OUTPUT +!- +!- ttm : size of time axis +!- itaus : Time steps within this file +!- date0 : Julian date at which itau = 0 +!- dt : length of the time steps of the data +!- fid : returned file ID which is later used to read the data +!--------------------------------------------------------------------- + MODULE PROCEDURE flinopen_zoom2d, flinopen_nozoom + END INTERFACE +!- + INTERFACE flinput +!--------------------------------------------------------------------- +!- The "flinput" routines will put a variable +!- on the netCDF file created by flincre. +!- If the sizes of the axis do not match the one of the IDs +!- then a new axis is created. +!- That is we loose the possibility of writting hyperslabs of data. +!- +!- Again here if iim = jjm = llm = ttm = 0 +!- then a global attribute is added to the file. +!- +!- INPUT +!- +!- fid : Identification of the file in which we will write +!- varname : Name of variable to be written +!- iim : size in x of variable +!- nlonid : ID of x axis which could fit for this axis +!- jjm : size in y of variable +!- nlatid : ID of y axis which could fit for this axis +!- llm : size in z of variable +!- zdimid : ID of z axis which could fit for this axis +!- ttm : size in t of variable +!- tdimid : ID of t axis which could fit for this axis +!- +!- OUTPUT +!- +!- NONE +!--------------------------------------------------------------------- + MODULE PROCEDURE flinput_r4d, flinput_r3d, flinput_r2d, & + flinput_r1d, flinput_scal + END INTERFACE +!- + INTERFACE flinget + MODULE PROCEDURE flinget_r4d, flinget_r3d, flinget_r2d, & + flinget_r1d, flinget_scal, & + flinget_r4d_zoom2d, flinget_r3d_zoom2d, & + flinget_r2d_zoom2d + END INTERFACE +!- +! This is the data we keep on each file we open +!- + INTEGER, PARAMETER :: nbfile_max = 200 + INTEGER, SAVE :: nbfiles = 0 + INTEGER, SAVE :: ncids(nbfile_max), ncnbd(nbfile_max), & + ncfunli(nbfile_max), ncnba(nbfile_max) + INTEGER, SAVE :: ncnbva(nbfile_max), ncdims(nbfile_max,4) + LOGICAL, SAVE :: ncfileopen(nbfile_max)=.FALSE. +!- + INTEGER, SAVE :: cind_vid, cind_fid, cind_len + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: cindex +!- + INTEGER,DIMENSION(4) :: w_sta, w_len, w_dim +!- +CONTAINS +!- +!=== +!- +SUBROUTINE flincre & + (filename, iim1, jjm1, lon1, lat1, llm1, lev1, ttm1, itaus, & + time0, dt, fid_out, nlonid1, nlatid1, zdimid1, tdimid1) +!--------------------------------------------------------------------- +!- This is a "low level" subroutine for opening netCDF files wich +!- contain the major coordinate system of the model. +!- Other coordinates needed for other variables +!- will be added as they are needed. +!- +!- INPUT +!- +!- filename : Name of the file to be created +!- iim1, jjm1 : Horizontal size of the grid +!- which will be stored in the file +!- lon1, lat1 : Horizontal grids +!- llm1 : Size of the vertical grid +!- lev1 : Vertical grid +!- ttm1 : Size of time axis +!- itaus : time steps on the time axis +!- time0 : Time in julian days at which itau = 0 +!- dt : time step in seconds between itaus +!- (one step of itau) +!- +!- OUTPUT +!- +!- fid : File identification +!- nlonid1 : Identification of longitudinal axis +!- nlatid1 : Identification of latitudinal axis +!- zdimid1 : ID of vertical axis +!- tdimid1 : ID of time axis +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + INTEGER :: iim1, jjm1, llm1, ttm1 + REAL :: lon1(iim1,jjm1) + REAL :: lat1(iim1,jjm1) + REAL :: lev1(llm1) + INTEGER :: itaus(ttm1) + REAL :: time0 + REAL :: dt + INTEGER :: fid_out, zdimid1, nlonid1, nlatid1, tdimid1 +!- +! LOCAL +!- + INTEGER :: iret, lll, fid + INTEGER :: lonid, latid, levid, timeid + INTEGER :: year, month, day + REAL :: sec + CHARACTER(LEN=250):: name +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + lll = LEN_TRIM(filename) + IF (filename(lll-2:lll) /= '.nc') THEN + name=filename(1:lll)//'.nc' + ELSE + name=filename(1:lll) + ENDIF +!- + iret = NF90_CREATE (name, NF90_CLOBBER, fid) +!- + iret = NF90_DEF_DIM (fid, 'x', iim1, nlonid1) + iret = NF90_DEF_DIM (fid, 'y', jjm1, nlatid1) + iret = NF90_DEF_DIM (fid, 'lev', llm1, zdimid1) + iret = NF90_DEF_DIM (fid, 'tstep', ttm1, tdimid1) +!- +! Vertical axis +!- + IF (check) WRITE(*,*) 'flincre Vertical axis' +!- + iret = NF90_DEF_VAR (fid, 'lev', NF90_FLOAT, zdimid1, levid) + iret = NF90_PUT_ATT (fid, levid, 'units', '-') + iret = NF90_PUT_ATT (fid, levid, 'title', 'levels') + iret = NF90_PUT_ATT (fid, levid, 'long_name', 'Sigma Levels') +!- +! Time axis +!- + IF (check) WRITE(*,*) 'flincre time axis' +!- + iret = NF90_DEF_VAR (fid, 'tstep', NF90_FLOAT, tdimid1, timeid) + iret = NF90_PUT_ATT (fid, timeid, 'units', '-') + iret = NF90_PUT_ATT (fid, timeid, 'title', 'time') + iret = NF90_PUT_ATT (fid, timeid, 'long_name', 'time steps') +!- +! The longitude +!- + IF (check) WRITE(*,*) 'flincre Longitude axis' +!- + iret = NF90_DEF_VAR (fid, "nav_lon", NF90_FLOAT, & + (/ nlonid1, nlatid1 /), lonid) + iret = NF90_PUT_ATT (fid, lonid, 'units', "degrees_east") + iret = NF90_PUT_ATT (fid, lonid, 'title', "Longitude") + iret = NF90_PUT_ATT (fid, lonid, 'nav_model', & + "Lambert projection of PROMES") + iret = NF90_PUT_ATT (fid, lonid, 'valid_min', & + REAL(MINVAL(lon1),KIND=4)) + iret = NF90_PUT_ATT (fid, lonid, 'valid_max', & + REAL(MAXVAL(lon1),KIND=4)) +!- +! The Latitude +!- + IF (check) WRITE(*,*) 'flincre Latitude axis' +!- + iret = NF90_DEF_VAR (fid, "nav_lat", NF90_FLOAT, & + (/ nlonid1, nlatid1 /), latid) + iret = NF90_PUT_ATT (fid, latid, 'units', "degrees_north") + iret = NF90_PUT_ATT (fid, latid, 'title', "Latitude") + iret = NF90_PUT_ATT (fid, latid, 'nav_model', & + "Lambert projection of PROMES") + iret = NF90_PUT_ATT (fid, latid, 'valid_min', & + REAL(MINVAL(lat1),KIND=4)) + iret = NF90_PUT_ATT (fid, latid, 'valid_max', & + REAL(MAXVAL(lat1),KIND=4)) +!- +! The time coordinates +!- + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', & + REAL(dt,KIND=4)) +!- + CALL ju2ymds (time0, year, month, day, sec) +!- + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'year0', REAL(year,KIND=4)) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'month0', REAL(month,KIND=4)) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'day0', REAL(day,KIND=4)) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'sec0', REAL(sec,KIND=4)) +!- + iret = NF90_ENDDEF (fid) +!- + IF (check) WRITE(*,*) 'flincre Variable' +!- + iret = NF90_PUT_VAR (fid, levid, lev1(1:llm1)) +!- + IF (check) WRITE(*,*) 'flincre Time Variable' +!- + iret = NF90_PUT_VAR (fid, timeid, REAL(itaus(1:ttm1))) +!- + IF (check) WRITE(*,*) 'flincre Longitude' +!- + iret = NF90_PUT_VAR (fid, lonid, lon1(1:iim1,1:jjm1)) +!- + IF (check) WRITE(*,*) 'flincre Latitude' +!- + iret = NF90_PUT_VAR (fid, latid, lat1(1:iim1,1:jjm1)) +!- +! Keep all this information +!- + nbfiles = nbfiles+1 +!- + IF (nbfiles > nbfile_max) THEN + CALL histerr (3,'flincre', & + 'Too many files. Please increase nbfil_max', & + 'in program flincom.F90.',' ') + ENDIF +!- + ncids(nbfiles) = fid + ncnbd(nbfiles) = 4 +!- + ncdims(nbfiles,1:4) = (/ iim1, jjm1, llm1, ttm1 /) +!- + ncfunli(nbfiles) = -1 + ncnba(nbfiles) = 4 + ncnbva(nbfiles) = 0 + ncfileopen(nbfiles) = .TRUE. +!- + fid_out = nbfiles +!--------------------- +END SUBROUTINE flincre +!- +!=== +!- +SUBROUTINE flinopen_zoom2d & + (filename, iideb, iilen, jjdeb, jjlen, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + LOGICAL :: do_test + INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen + REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm) + INTEGER :: itaus(ttm) + REAL :: date0, dt + INTEGER :: fid_out +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE (*,*) ' iideb, iilen, jjdeb, jjlen, iim, jjm ', & + iideb, iilen, jjdeb, jjlen, iim, jjm + IF (check) WRITE (*,*) ' lon ', lon(1,1), lon(iilen,jjlen) + IF (check) WRITE (*,*) ' lat ', lat(1,1), lat(iilen,jjlen) +!- + CALL flinopen_work & + (filename, iideb, iilen, jjdeb, jjlen, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!----------------------------- +END SUBROUTINE flinopen_zoom2d +!- +!=== +!- +SUBROUTINE flinopen_nozoom & + (filename, do_test, iim, jjm, llm, lon, lat, lev, ttm, & + itaus, date0, dt, fid_out) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + LOGICAL :: do_test + INTEGER :: iim, jjm, llm, ttm + REAL :: lon(iim,jjm), lat(iim,jjm), lev(llm) + INTEGER :: itaus(ttm) + REAL :: date0, dt + INTEGER :: fid_out +!--------------------------------------------------------------------- + CALL flinopen_work & + (filename, 1, iim, 1, jjm, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!------------------------- +END SUBROUTINE flinopen_nozoom +!- +!=== +!- +SUBROUTINE flinopen_work & + (filename, iideb, iilen, jjdeb, jjlen, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + LOGICAL :: do_test + INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen + REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm) + INTEGER :: itaus(ttm) + REAL :: date0, dt + INTEGER :: fid_out +!- +! LOCAL +!- + REAL, PARAMETER :: eps = 1.e-4 +!- + INTEGER :: iret, vid, fid, nbdim, i, iilast, jjlast + INTEGER :: gdtt_id, old_id, iv, gdtmaf_id + CHARACTER(LEN=250) :: name + CHARACTER(LEN=80) :: units, calendar + INTEGER :: tmp_iim, tmp_jjm, tmp_llm, tmp_ttm + REAL :: x_first, x_last + INTEGER :: year, month, day + REAL :: r_year, r_month, r_day + INTEGER :: year0, month0, day0, hours0, minutes0, seci + REAL :: sec, sec0 + CHARACTER :: strc +!- + REAL,DIMENSION(:),ALLOCATABLE :: vec_tmp +!- + LOGICAL :: open_file + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + iilast = iideb+iilen-1 + jjlast = jjdeb+jjlen-1 + IF (check) WRITE (*,*) & + ' flinopen_work zoom 2D information '// & + ' iideb, iilen, iilast, jjdeb, jjlen, jjlast ', & + iideb, iilen, iilast, jjdeb, jjlen, jjlast +!- +! 1.0 get all infos on the file +!- +! Either the fid_out has not been initialized (0 or very large) +! then we have to open anyway. Else we only need to open the file +! if it has not been opened before. +!- + IF ( (fid_out < 1).OR.(fid_out > nbfile_max) ) THEN + open_file = .TRUE. + ELSE IF (.NOT.ncfileopen(fid_out)) THEN + open_file = .TRUE. + ELSE + open_file = .FALSE. + ENDIF +!- + IF (open_file) THEN + CALL flininfo (filename,tmp_iim,tmp_jjm,tmp_llm,tmp_ttm,fid_out) + ELSE +!-- The user has already opened the file +!-- and we trust that he knows the dimensions + tmp_iim = iim + tmp_jjm = jjm + tmp_llm = llm + tmp_ttm = ttm + ENDIF +!- + IF (check) & + WRITE(*,*) 'OUT OF flininfo :',tmp_iim,tmp_jjm,tmp_llm,tmp_ttm +!- + fid = ncids(fid_out) +!- +! 2.0 get the sizes and names of the different coordinates +! and do a first set of verification. +!- +! 2.2 We test the axis if we have to. +!- + IF (check) & + WRITE(*,*) 'flininfo 2.2 We test if we have to test : ',do_test +!- + IF (do_test) THEN + IF (iim /= tmp_iim) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' does not have the ', & + 'required dimension in x direction (longitude)',' ') + ELSE IF (jjm /= tmp_jjm) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' does not have the ', & + 'required dimension in y direction (latitude)',' ') + ELSE IF ( llm /= tmp_llm .AND. llm > 0 ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' does not have the ', & + 'required dimension in the vertical',' ') + ENDIF + ELSE +!--- +!-- 2.3 Else the sizes of the axes are returned to the user +!--- + IF (check) WRITE(*,*) 'flinopen 2.3 Else sizes are returned' +!--- + iim = tmp_iim + jjm = tmp_jjm + llm = tmp_llm + ENDIF +!- + ttm = tmp_ttm +!- +! 3.0 Check if we are realy talking about the same coodinate system +! if not then we get the lon, lat and lev variables from the file +!- + IF (check) WRITE(*,*) 'flinopen 3.0 we are realy talking' +!- + IF (do_test) THEN +!--- + CALL flinfindcood (fid_out, 'lon', vid, nbdim) + iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /)) + iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /)) +!--- + IF (check) & + WRITE(*,*) 'from file lon first and last, modulo 360. ', & + x_first, x_last, MODULO(x_first,360.), MODULO(x_last,360.) + IF (check) & + WRITE(*,*) 'from model lon first and last, modulo 360. ', & + lon(1,1),lon(iilen,jjlen), & + MODULO(lon(1,1),360.), MODULO(lon(iilen,jjlen),360.) + IF ( (ABS( MODULO(x_first,360.) & + -MODULO(lon(1,1),360.)) > eps) & + .OR.(ABS( MODULO(x_last,360.) & + -MODULO(lon(iilen ,jjlen),360.)) > eps ) ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' and the model do not', & + 'share the same longitude coordinate', & + 'Obtained by comparing the first and last values ') + ENDIF +!--- + CALL flinfindcood (fid_out, 'lat', vid, nbdim) + iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /)) + iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /)) +!--- + IF (check) WRITE(*,*) & + 'from file lat first and last ',x_first,x_last + IF (check) WRITE(*,*) & + 'from model lat first and last ',lat(1,1),lat(iilen,jjlen) +!--- + IF ( (ABS(x_first-lat(1,1)) > eps) & + .OR.(ABS(x_last-lat(iilen,jjlen)) > eps) ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' and the model do not', & + 'share the same latitude coordinate', & + 'Obtained by comparing the first and last values ') + ENDIF +!--- + IF (llm > 0) THEN + CALL flinfindcood (fid_out, 'lev', vid, nbdim) + iret = NF90_GET_VAR (fid, vid, x_first, start=(/ 1 /)) + iret = NF90_GET_VAR (fid, vid, x_last, start=(/ llm /)) +!----- + IF (check) WRITE(*,*) & + 'from file lev first and last ',x_first ,x_last + IF (check) WRITE(*,*) & + 'from model lev first and last ',lev(1),lev(llm) +!----- + IF ( (ABS(x_first-lev(1)) > eps) & + .OR.(ABS(x_last-lev(llm)) > eps) ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' and the model do not', & + 'share the same vertical coordinate', & + 'Obtained by comparing the first and last values') + ENDIF + ENDIF +!--- + ELSE +!--- +!-- 4.0 extracting the coordinates if we do not check +!--- + IF (check) WRITE(*,*) 'flinopen 4.0 extracting the coordinates' +!--- + CALL flinfindcood (fid_out, 'lon', vid, nbdim) + IF (nbdim == 2) THEN + iret = NF90_GET_VAR (fid, vid, lon, & + start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /)) + ELSE + ALLOCATE(vec_tmp(iilen)) + iret = NF90_GET_VAR (fid, vid, vec_tmp, & + start=(/ iideb /), count=(/ iilen /)) + DO i=1,jjlen + lon(:,i) = vec_tmp(:) + ENDDO + DEALLOCATE(vec_tmp) + ENDIF +!--- + CALL flinfindcood (fid_out, 'lat', vid, nbdim) + IF (nbdim == 2) THEN + iret = NF90_GET_VAR (fid, vid, lat, & + start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /)) + ELSE + ALLOCATE(vec_tmp(jjlen)) + iret = NF90_GET_VAR (fid, vid, vec_tmp, & + start=(/ jjdeb /), count=(/ jjlen /)) + DO i=1,iilen + lat(i,:) = vec_tmp(:) + ENDDO + DEALLOCATE(vec_tmp) + ENDIF +!--- + IF (llm > 0) THEN + CALL flinfindcood (fid_out, 'lev', vid, nbdim) + IF (nbdim == 1) THEN + iret = NF90_GET_VAR (fid, vid, lev, & + start=(/ 1 /), count=(/ llm /)) + ELSE + CALL histerr (3,'flinopen', & + 'Can not handle vertical coordinates that have more',& + 'than 1 dimension',' ') + ENDIF + ENDIF + ENDIF +!- +! 5.0 Get all the details for the time if possible needed +!- + IF (check) WRITE(*,*) 'flinopen 5.0 Get time' +!- + IF (ttm > 0) THEN +!--- +!-- 5.1 Find the time axis. Prefered method is the 'timestep since' +!--- + gdtmaf_id = -1 + gdtt_id = -1 + old_id = -1 + DO iv=1,ncnbva(fid_out) + name='' + iret = NF90_INQUIRE_VARIABLE (fid, iv, name=name) + units='' + iret = NF90_GET_ATT (fid, iv, 'units', units) + IF (INDEX(units,'seconds since') > 0) gdtmaf_id = iv + IF (INDEX(units,'timesteps since') > 0) gdtt_id = iv + IF (INDEX(name, 'tstep') > 0) old_id = iv + ENDDO +!--- + IF (gdtt_id > 0) THEN + vid = gdtt_id + ELSE IF (gdtmaf_id > 0) THEN + vid = gdtmaf_id + ELSE IF (old_id > 0) THEN + vid = old_id + ELSE + CALL histerr (3, 'flinopen', 'No time axis found',' ',' ') + ENDIF +!--- + ALLOCATE(vec_tmp(ttm)) + iret = NF90_GET_VAR (fid,vid,vec_tmp,start=(/ 1 /),count=(/ ttm /)) + itaus(1:ttm) = NINT(vec_tmp(1:ttm)) + DEALLOCATE(vec_tmp) +!--- + IF (check) WRITE(*,*) 'flinopen 5.1 Times ',itaus +!--- +!-- Getting all the details for the time axis +!--- +!-- Find the calendar + calendar = '' + iret = NF90_GET_ATT (fid,gdtmaf_id,'calendar',calendar) + IF (iret == NF90_NOERR) THEN + CALL ioconf_calendar(calendar) + ENDIF +!-- + units = '' + iret = NF90_GET_ATT (fid,vid,'units',units) + IF (gdtt_id > 0) THEN + units = units(INDEX(units,'since')+6:LEN_TRIM(units)) + READ (units,'(I4.4,5(a,I2.2))') & + year0, strc, month0, strc, day0, & + strc, hours0, strc, minutes0, strc, seci + sec0 = hours0*3600. + minutes0*60. + seci + CALL ymds2ju (year0, month0, day0, sec0, date0) + IF (check) & + WRITE(*,*) 'flinopen 5.1 gdtt_id year0 ... date0 ', & + year0, month0, day0, sec0, date0 +!----- + iret = NF90_GET_ATT (fid, gdtt_id, 'tstep_sec', dt) + ELSE IF (gdtmaf_id > 0) THEN + units = units(INDEX(units,'since')+6:LEN_TRIM(units)) + READ (units,'(I4.4,5(a,I2.2))') & + year0, strc, month0, strc, day0, & + strc, hours0, strc, minutes0, strc, seci + sec0 = hours0*3600. + minutes0*60. + seci + CALL ymds2ju (year0, month0, day0, sec0, date0) +!----- + IF (check) & + WRITE(*,*) 'flinopen 5.1 gdtmaf_id year0 ... date0 ', & + year0, month0, day0, sec0, date0 + ELSE IF (old_id > 0) THEN + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', dt) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'day0', r_day) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'sec0', sec) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'year0', r_year) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'month0', r_month) +!----- + day = INT(r_day) + month = INT(r_month) + year = INT(r_year) +!----- + CALL ymds2ju (year, month, day, sec, date0) + ENDIF + ENDIF +!- + IF (check) WRITE(*,*) 'flinopen 6.0 File opened', date0, dt +!--------------------------- +END SUBROUTINE flinopen_work +!- +!=== +!- +SUBROUTINE flininfo (filename, iim, jjm, llm, ttm, fid_out) +!--------------------------------------------------------------------- +!- This subroutine allows to get some information. +!- It is usualy done within flinopen but the user may want to call +!- it before in order to allocate the space needed to extract the +!- data from the file. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + INTEGER :: iim, jjm, llm, ttm, fid_out +!- +! LOCAL +!- + INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim + INTEGER :: iv, lll + INTEGER :: xid, yid, zid, tid + CHARACTER(LEN=80) :: name + CHARACTER(LEN=30) :: axname +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + lll = LEN_TRIM(filename) + IF (filename(lll-2:lll) /= '.nc') THEN + name = filename(1:lll)//'.nc' + ELSE + name = filename(1:lll) + ENDIF +!- + iret = NF90_OPEN (name, NF90_NOWRITE, fid) + IF (iret /= NF90_NOERR) THEN + CALL histerr(3, 'flininfo','Could not open file :',TRIM(name),' ') + ENDIF +!- + iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, & + nAttributes=nb_atts, unlimitedDimId=id_unlim) +!- + xid = -1; iim = 0; + yid = -1; jjm = 0; + zid = -1; llm = 0; + tid = -1; ttm = 0; +!- + DO iv=1,ndims +!--- + iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll) + CALL strlowercase (axname) + axname = ADJUSTL(axname) +!--- + IF (check) WRITE(*,*) & + 'flininfo - getting axname',iv,axname,lll +!--- + IF ( (INDEX(axname,'x') == 1) & + .OR.(INDEX(axname,'lon') == 1) ) THEN + xid = iv; iim = lll; + ELSE IF ( (INDEX(axname,'y') == 1) & + .OR.(INDEX(axname,'lat') == 1) ) THEN + yid = iv; jjm = lll; + ELSE IF ( (INDEX(axname,'lev') == 1) & + .OR.(INDEX(axname,'plev') == 1) & + .OR.(INDEX(axname,'z') == 1) & + .OR.(INDEX(axname,'depth') == 1) ) THEN + zid = iv; llm = lll; + ELSE IF ( (INDEX(axname,'tstep') == 1) & + .OR.(INDEX(axname,'time_counter') == 1) ) THEN +!---- For the time we certainly need to allow for other names + tid = iv; ttm = lll; + ELSE IF (ndims == 1) THEN +!---- Nothing was found and ndims=1 then we have a vector of data + xid = 1; iim = lll; + ENDIF +!--- + ENDDO +!- +! Keep all this information +!- + nbfiles = nbfiles+1 +!- + IF (nbfiles > nbfile_max) THEN + CALL histerr (3,'flininfo', & + 'Too many files. Please increase nbfil_max', & + 'in program flincom.F90.',' ') + ENDIF +!- + ncids(nbfiles) = fid + ncnbd(nbfiles) = ndims +!- + ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /) +!- + ncfunli(nbfiles) = id_unlim + ncnba(nbfiles) = nb_atts + ncnbva(nbfiles) = nvars + ncfileopen(nbfiles) = .TRUE. +!- + fid_out = nbfiles +!---------------------- +END SUBROUTINE flininfo +!- +!=== +!- +SUBROUTINE flinput_r1d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r1d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r1d +!- +!=== +!- +SUBROUTINE flinput_r2d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:,:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r2d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r2d +!- +!=== +!- +SUBROUTINE flinput_r3d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:,:,:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r3d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r3d +!- +!=== +!- +SUBROUTINE flinput_r4d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:,:,:,:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r4d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r4d +!- +!=== +!- +SUBROUTINE flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid, & + llm,zdimid,ttm,tdimid,fid,ncvarid,ndim) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + INTEGER :: fid, ncvarid, ndim +!- +! LOCAL +!- + INTEGER :: iret +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + w_sta(1:4) = (/ 1, 1, 1, 1 /) + w_len(1:2) = (/ iim, jjm /) + w_dim(1:2) = (/ nlonid, nlatid /) +!- + IF ( (llm > 0).AND.(ttm > 0) ) THEN + ndim = 4 + w_len(3:4) = (/ llm, ttm /) + w_dim(3:4) = (/ zdimid, tdimid /) + ELSE IF (llm > 0) THEN + ndim = 3 + w_dim(3) = zdimid + w_len(3) = llm + ELSE IF (ttm > 0) THEN + ndim = 3 + w_dim(3) = tdimid + w_len(3) = ttm + ELSE + ndim = 2 + ENDIF +!- + iret = NF90_REDEF (fid) + iret = NF90_DEF_VAR (fid,varname,NF90_FLOAT,w_dim(1:ndim),ncvarid) + iret = NF90_PUT_ATT (fid,ncvarid,'short_name',TRIM(varname)) + iret = NF90_ENDDEF (fid) +!-------------------------- +END SUBROUTINE flinput_mat +!- +!=== +!- +SUBROUTINE flinput_scal & + (fid_in, varname, iim, nlonid, jjm, nlatid, & + llm, zdimid, ttm, tdimid, var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var +!- +! LOCAL +!- + INTEGER :: fid, iret +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + iret = NF90_REDEF (fid) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, varname, REAL(var,KIND=4)) + iret = NF90_ENDDEF (fid) +!--------------------------- +END SUBROUTINE flinput_scal +!- +!=== +!- +SUBROUTINE flinget_r1d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:) +!- + INTEGER :: jl, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r1d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r1d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji) = buff_tmp(jl) + ENDDO +!------------------------- +END SUBROUTINE flinget_r1d +!- +!=== +!- +SUBROUTINE flinget_r2d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:,:) +!- + INTEGER :: jl, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj) = buff_tmp(jl) + ENDDO + ENDDO +!------------------------- +END SUBROUTINE flinget_r2d +!- +!=== +!- +SUBROUTINE flinget_r2d_zoom2d & + (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen + REAL :: var(:,:) +!- + INTEGER :: jl, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp) +!- + jl=0 + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj) = buff_tmp(jl) + ENDDO + ENDDO +!-------------------------------- +END SUBROUTINE flinget_r2d_zoom2d +!- +!=== +!- +SUBROUTINE flinget_r3d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:,:,:) +!- + INTEGER :: jl, jk, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO +!------------------------- +END SUBROUTINE flinget_r3d +!- +!=== +!- +SUBROUTINE flinget_r3d_zoom2d & + (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen + REAL :: var(:,:,:) +!- + INTEGER :: jl, jk, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp) +!- + jl=0 + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO +!-------------------------------- +END SUBROUTINE flinget_r3d_zoom2d +!- +!=== +!- +SUBROUTINE flinget_r4d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:,:,:,:) +!- + INTEGER :: jl, jk, jj, ji, jm + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO jm=1,SIZE(var,4) + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk,jm) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO + ENDDO +!------------------------- +END SUBROUTINE flinget_r4d +!- +!=== +!- +SUBROUTINE flinget_r4d_zoom2d & + (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen + REAL :: var(:,:,:,:) +!- + INTEGER :: jl, jk, jj, ji, jm + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp) +!- + jl=0 + DO jm=1,SIZE(var,4) + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk,jm) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO + ENDDO +!-------------------------------- +END SUBROUTINE flinget_r4d_zoom2d +!- +!=== +!- +SUBROUTINE flinget_mat & + (fid_in, varname, iim, jjm, llm, ttm, itau_dep, & + itau_fin, iideb, iilen, jjdeb, jjlen, var) +!--------------------------------------------------------------------- +!- This subroutine will read the variable named varname from +!- the file previously opened by flinopen and identified by fid +!- +!- It is checked that the dimensions of the variable to be read +!- correspond to what the user requested when he specified +!- iim, jjm and llm. The only exception which is allowed is +!- for compressed data where the horizontal grid is not expected +!- to be iim x jjm. +!- +!- If variable is of size zero a global attribute is read. +!- This global attribute will be of type real +!- +!- INPUT +!- +!- fid : File ID returned by flinopen +!- varname : Name of the variable to be read from the file +!- iim : | These three variables give the size of the variables +!- jjm : | to be read. It will be verified that the variables +!- llm : | fits in there. +!- ttm : | +!- itau_dep : Time step at which we will start to read +!- itau_fin : Time step until which we are going to read +!- For the moment this is done on indexes +!- but it should be in the physical space. +!- If there is no time-axis in the file then use a +!- itau_fin < itau_dep, this will tell flinget not to +!- expect a time-axis in the file. +!- iideb : index i for zoom +!- iilen : length of zoom +!- jjdeb : index j for zoom +!- jjlen : length of zoom +!- +!- OUTPUT +!- +!- var : array that will contain the data +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm + INTEGER :: itau_dep, itau_fin, iideb, iilen, jjdeb, jjlen + REAL :: var(:) +!- +! LOCAL +!- + INTEGER :: iret, fid + INTEGER :: vid, cvid, clen + CHARACTER(LEN=70) :: str1 + CHARACTER(LEN=250) :: att_n, tmp_n + CHARACTER(LEN=5) :: axs_l + INTEGER :: tmp_i + REAL,SAVE :: mis_v=0. + REAL :: tmp_r + INTEGER :: ndims, x_typ, nb_atts + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dimids + INTEGER :: i, nvars, i2d, cnd + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: var_tmp + LOGICAL :: uncompress = .FALSE. + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + IF (check) THEN + WRITE(*,*) & + 'flinget_mat : fid_in, fid, varname :', fid_in, fid, TRIM(varname) + WRITE(*,*) & + 'flinget_mat : iim, jjm, llm, ttm, itau_dep, itau_fin :', & + iim, jjm, llm, ttm, itau_dep, itau_fin + WRITE(*,*) & + 'flinget_mat : iideb, iilen, jjdeb, jjlen :', & + iideb, iilen, jjdeb, jjlen + ENDIF +!- + uncompress = .FALSE. +!- +! 1.0 We get first all the details on this variable from the file +!- + nvars = ncnbva(fid_in) +!- + vid = -1 + iret = NF90_INQ_VARID (fid, varname, vid) +!- + IF (vid < 0 .OR. iret /= NF90_NOERR) THEN + CALL histerr (3,'flinget', & + 'Variable '//TRIM(varname)//' not found in file',' ',' ') + ENDIF +!- + iret = NF90_INQUIRE_VARIABLE (fid, vid, & + ndims=ndims, dimids=dimids, nAtts=nb_atts) + IF (check) THEN + WRITE(*,*) & + 'flinget_mat : fid, vid :', fid, vid + WRITE(*,*) & + 'flinget_mat : ndims, dimids(1:ndims), nb_atts :', & + ndims, dimids(1:ndims), nb_atts + ENDIF +!- + w_dim(:) = 0 + DO i=1,ndims + iret = NF90_INQUIRE_DIMENSION (fid, dimids(i), len=w_dim(i)) + ENDDO + IF (check) WRITE(*,*) & + 'flinget_mat : w_dim :', w_dim(1:ndims) +!- + mis_v = 0.0; axs_l = ' '; +!- + IF (nb_atts > 0) THEN + IF (check) THEN + WRITE(*,*) 'flinget_mat : attributes for variable :' + ENDIF + ENDIF + DO i=1,nb_atts + iret = NF90_INQ_ATTNAME (fid, vid, i, att_n) + iret = NF90_INQUIRE_ATTRIBUTE (fid, vid, att_n, xtype=x_typ) + CALL strlowercase (att_n) + IF ( (x_typ == NF90_INT).OR.(x_typ == NF90_SHORT) & + .OR.(x_typ == NF90_BYTE) ) THEN + iret = NF90_GET_ATT (fid, vid, att_n, tmp_i) + IF (check) THEN + WRITE(*,*) ' ',TRIM(att_n),' : ',tmp_i + ENDIF + ELSE IF ( (x_typ == NF90_FLOAT).OR.(x_typ == NF90_DOUBLE) ) THEN + iret = NF90_GET_ATT (fid, vid, att_n, tmp_r) + IF (check) THEN + WRITE(*,*) ' ',TRIM(att_n),' : ',tmp_r + ENDIF + IF (index(att_n,'missing_value') > 0) THEN + mis_v = tmp_r + ENDIF + ELSE + tmp_n = '' + iret = NF90_GET_ATT (fid, vid, att_n, tmp_n) + IF (check) THEN + WRITE(*,*) ' ',TRIM(att_n),' : ',TRIM(tmp_n) + ENDIF + IF (index(att_n,'axis') > 0) THEN + axs_l = tmp_n + ENDIF + ENDIF + ENDDO +!? +!!!!!!!!!! We will need a verification on the type of the variable +!? +!- +! 2.0 The dimensions are analysed to determine what is to be read +!- +! 2.1 the longitudes +!- + IF ( w_dim(1) /= iim .OR. w_dim(2) /= jjm) THEN +!--- +!-- There is a possibility that we have to deal with a compressed axis ! +!--- + iret = NF90_INQUIRE_DIMENSION (fid, dimids(1), & + name=tmp_n, len=clen) + iret = NF90_INQ_VARID (fid, tmp_n, cvid) +!--- + IF (check) WRITE(*,*) & + 'Dimname, iret , NF90_NOERR : ',TRIM(tmp_n),iret,NF90_NOERR +!--- +!-- If we have an axis which has the same name +!-- as the dimension we can see if it is compressed +!--- +!-- TODO TODO for zoom2d +!--- + IF (iret == NF90_NOERR) THEN + iret = NF90_GET_ATT (fid, cvid, 'compress', str1) +!----- + IF (iret == NF90_NOERR) THEN + iret = NF90_INQUIRE_VARIABLE (fid,cvid,xtype=x_typ,ndims=cnd) +!------- + IF ( cnd /= 1 .AND. x_typ /= NF90_INT) THEN + CALL histerr (3,'flinget', & + 'Variable '//TRIM(tmp_n)//' can not be a compressed axis', & + 'Either it has too many dimensions'// & + ' or it is not of type integer', ' ') + ELSE +!--------- +!-------- Let us see if we already have that index table +!--------- + IF ( (cind_len /= clen).OR.(cind_vid /= cvid) & + .OR.(cind_fid /= fid) ) THEN + IF (ALLOCATED(cindex)) DEALLOCATE(cindex) + ALLOCATE(cindex(clen)) + cind_len = clen + cind_vid = cvid + cind_fid = fid + iret = NF90_GET_VAR (fid, cvid, cindex) + ENDIF +!--------- +!-------- In any case we need to set the slab of data to be read +!--------- + uncompress = .TRUE. + w_sta(1) = 1 + w_len(1) = clen + i2d = 1 + ENDIF + ELSE + str1 = 'The horizontal dimensions of '//varname + CALL histerr (3,'flinget',str1, & + 'is not compressed and does not'// & + ' correspond to the requested size',' ') + ENDIF + ELSE + IF (w_dim(1) /= iim) THEN + str1 = 'The longitude dimension of '//varname + CALL histerr (3,'flinget',str1, & + 'in the file is not equal to the dimension', & + 'that should be read') + ENDIF + IF (w_dim(2) /= jjm) THEN + str1 = 'The latitude dimension of '//varname + CALL histerr (3,'flinget',str1, & + 'in the file is not equal to the dimension', & + 'that should be read') + ENDIF + ENDIF + ELSE + w_sta(1:2) = (/ iideb, jjdeb /) + w_len(1:2) = (/ iilen, jjlen /) + i2d = 2 + ENDIF +!- +! 2.3 Now the difficult part, the 3rd dimension which can be +! time or levels. +!- +! Priority is given to the time axis if only three axes are present. +!- + IF (ndims > i2d) THEN +!--- +!-- 2.3.1 We have a vertical axis +!--- + IF (llm == 1 .AND. ndims == i2d+2 .OR. llm == w_dim(i2d+1)) THEN +!----- + IF (w_dim(i2d+1) /= llm) THEN + CALL histerr (3,'flinget', & + 'The vertical dimension of '//varname, & + 'in the file is not equal to the dimension', & + 'that should be read') + ELSE + w_sta(i2d+1) = 1 + IF (llm > 0) THEN + w_len(i2d+1) = llm + ELSE + w_len(i2d+1) = w_sta(i2d+1) + ENDIF + ENDIF +!----- + IF ((itau_fin-itau_dep) >= 0) THEN + IF (ndims /= i2d+2) THEN + CALL histerr (3,'flinget', & + 'You attempt to read a time slab', & + 'but there is no time axis on this variable', varname) + ELSE IF ((itau_fin - itau_dep) <= w_dim(i2d+2)) THEN + w_sta(i2d+2) = itau_dep + w_len(i2d+2) = itau_fin-itau_dep+1 + ELSE + CALL histerr (3,'flinget', & + 'The time step you try to read is not', & + 'in the file (1)', varname) + ENDIF + ELSE IF (ndims == i2d+2 .AND. w_dim(i2d+2) > 1) THEN + CALL histerr (3,'flinget', & + 'There is a time axis in the file but no', & + 'time step give in the call', varname) + ELSE + w_sta(i2d+2) = 1 + w_len(i2d+2) = 1 + ENDIF + ELSE +!----- +!---- 2.3.2 We do not have any vertical axis +!----- + IF (ndims == i2d+2) THEN + CALL histerr (3,'flinget', & + 'The file contains 4 dimensions', & + 'but only 3 are requestes for variable ', varname) + ENDIF + IF ((itau_fin-itau_dep) >= 0) THEN + IF (ndims == i2d+1) THEN + IF ((itau_fin-itau_dep) < w_dim(i2d+1) ) THEN + w_sta(i2d+1) = itau_dep + w_len(i2d+1) = itau_fin-itau_dep+1 + ELSE + CALL histerr (3,'flinget', & + 'The time step you try to read is not', & + 'in the file (2)', varname) + ENDIF + ELSE + CALL histerr (3,'flinget', & + 'From your input you sould have 3 dimensions', & + 'in the file but there are 4', varname) + ENDIF + ELSE + IF (ndims == i2d+1 .AND. w_dim(i2d+1) > 1) THEN + CALL histerr (3,'flinget', & + 'There is a time axis in the file but no', & + 'time step given in the call', varname) + ELSE + w_sta(i2d+1) = 1 + w_len(i2d+1) = 1 + ENDIF + ENDIF + ENDIF + ELSE +!--- +!-- 2.3.3 We do not have any vertical axis +!--- + w_sta(i2d+1:i2d+2) = (/ 0, 0 /) + w_len(i2d+1:i2d+2) = (/ 0, 0 /) + ENDIF +!- +! 3.0 Reading the data +!- + IF (check) WRITE(*,*) & + 'flinget_mat 3.0 : ', uncompress, w_sta, w_len +!--- + IF (uncompress) THEN +!--- + IF (ALLOCATED(var_tmp)) THEN + IF (SIZE(var_tmp) < clen) THEN + DEALLOCATE(var_tmp) + ALLOCATE(var_tmp(clen)) + ENDIF + ELSE + ALLOCATE(var_tmp(clen)) + ENDIF +!--- + iret = NF90_GET_VAR (fid, vid, var_tmp, & + start=w_sta(:), count=w_len(:)) +!--- + var(:) = mis_v + var(cindex(:)) = var_tmp(:) +!--- + ELSE + iret = NF90_GET_VAR (fid, vid, var, & + start=w_sta(:), count=w_len(:)) + ENDIF +!- + IF (check) WRITE(*,*) 'flinget_mat 3.1 : ',NF90_STRERROR (iret) +!-------------------------- +END SUBROUTINE flinget_mat +!- +!=== +!- +SUBROUTINE flinget_scal & + (fid_in, varname, iim, jjm, llm, ttm, itau_dep, itau_fin, var) +!--------------------------------------------------------------------- +!- This subroutine will read the variable named varname from +!- the file previously opened by flinopen and identified by fid +!- +!- If variable is of size zero a global attribute is read. This +!- global attribute will be of type real +!- +!- INPUT +!- +!- fid : File ID returned by flinopen +!- varname : Name of the variable to be read from the file +!- iim : | These three variables give the size of the variables +!- jjm : | to be read. It will be verified that the variables +!- llm : | fits in there. +!- ttm : | +!- itau_dep : Time step at which we will start to read +!- itau_fin : Time step until which we are going to read +!- For the moment this is done on indeces but it should be +!- in the physical space +!- If there is no time-axis in the file then use a +!- itau_fin < itau_dep, this will tell flinget not to +!- expect a time-axis in the file. +!- +!- OUTPUT +!- +!- var : scalar that will contain the data +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var +!- +! LOCAL +!- + INTEGER :: iret, fid +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) THEN + WRITE (*,*) 'flinget_scal in file with id ',fid_in + ENDIF +!- + fid = ncids(fid_in) +!- +! 1.0 Reading a global attribute +!- + iret = NF90_GET_ATT (fid, NF90_GLOBAL, varname, var) +!--------------------------- +END SUBROUTINE flinget_scal +!- +!=== +!- +SUBROUTINE flinfindcood (fid_in, axtype, vid, ndim) +!--------------------------------------------------------------------- +!- This subroutine explores the file in order to find +!- the coordinate according to a number of rules +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: fid_in, vid, ndim + CHARACTER(LEN=3) :: axtype +!- +! LOCAL +!- + INTEGER :: iv, iret, dimnb + CHARACTER(LEN=40) :: dimname, dimuni1, dimuni2, dimuni3 + CHARACTER(LEN=80) :: str1 + LOGICAL :: found_rule = .FALSE. +!--------------------------------------------------------------------- + vid = -1 +!- +! Make sure all strings are invalid +!- + dimname = '?-?' + dimuni1 = '?-?' + dimuni2 = '?-?' + dimuni3 = '?-?' +!- +! First rule : we look for the correct units +! lon : east +! lat : north +! We make an exact check as it would be too easy to mistake +! some units by just comparing the substrings. +!- + SELECTCASE(axtype) + CASE ('lon') + dimuni1 = 'degree_e' + dimuni2 = 'degrees_e' + found_rule = .TRUE. + CASE('lat') + dimuni1 = 'degree_n' + dimuni2 = 'degrees_n' + found_rule = .TRUE. + CASE('lev') + dimuni1 = 'm' + dimuni2 = 'km' + dimuni3 = 'hpa' + found_rule = .TRUE. + CASE DEFAULT + found_rule = .FALSE. + END SELECT +!- + IF (found_rule) THEN + iv = 0 + DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) ) + iv = iv+1 + str1 = '' + iret = NF90_GET_ATT (ncids(fid_in), iv, 'units', str1) + IF (iret == NF90_NOERR) THEN + CALL strlowercase (str1) + IF ( (INDEX(str1, TRIM(dimuni1)) == 1) & + .OR.(INDEX(str1, TRIM(dimuni2)) == 1) & + .OR.(INDEX(str1, TRIM(dimuni3)) == 1) ) THEN + vid = iv + iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, ndims=ndim) + ENDIF + ENDIF + ENDDO + ENDIF +!- +! Second rule : we find specific names : +! lon : nav_lon +! lat : nav_lat +! Here we can check if we find the substring as the +! names are more specific. +!- + SELECTCASE(axtype) + CASE ('lon') + dimname = 'nav_lon lon longitude' + found_rule = .TRUE. + CASE('lat') + dimname = 'nav_lat lat latitude' + found_rule = .TRUE. + CASE('lev') + dimname = 'plev level depth deptht' + found_rule = .TRUE. + CASE DEFAULT + found_rule = .FALSE. + END SELECT +!- + IF (found_rule) THEN + iv = 0 + DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) ) + iv = iv+1 + str1='' + iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, & + name=str1, ndims=ndim) + IF (INDEX(dimname,TRIM(str1)) >= 1) THEN + vid = iv + ENDIF + ENDDO + ENDIF +!- +! Third rule : we find a variable with the same name as the dimension +! lon = 1 +! lat = 2 +! lev = 3 +!- + IF (vid < 0) THEN + SELECTCASE(axtype) + CASE ('lon') + dimnb = 1 + found_rule = .TRUE. + CASE('lat') + dimnb = 2 + found_rule = .TRUE. + CASE('lev') + dimnb = 3 + found_rule = .TRUE. + CASE DEFAULT + found_rule = .FALSE. + END SELECT +!--- + IF (found_rule) THEN + iret = NF90_INQUIRE_DIMENSION (ncids(fid_in), dimnb, name=dimname) + iv = 0 + DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) ) + iv = iv+1 + str1='' + iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, & + name=str1, ndims=ndim) + IF (INDEX(dimname,TRIM(str1)) == 1) THEN + vid = iv + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Stop the program if no coordinate was found +!- + IF (vid < 0) THEN + CALL histerr (3,'flinfindcood', & + 'No coordinate axis was found in the file', & + 'The data in this file can not be used', axtype) + ENDIF +!-------------------------- +END SUBROUTINE flinfindcood +!- +!=== +!- +SUBROUTINE flinclo (fid_in) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in +!- + INTEGER :: iret +!--------------------------------------------------------------------- + iret = NF90_CLOSE (ncids(fid_in)) + ncfileopen(fid_in) = .FALSE. +!--------------------- +END SUBROUTINE flinclo +!- +!=== +!- +SUBROUTINE flinquery_var(fid_in, varname, exists) +!--------------------------------------------------------------------- +!- Queries the existance of a variable in the file. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) varname + LOGICAL :: exists +!- + INTEGER :: iret, fid, vid +!--------------------------------------------------------------------- + fid = ncids(fid_in) + vid = -1 + iret = NF90_INQ_VARID (fid, varname, vid) +!- + exists = ( (vid >= 0).AND.(iret == NF90_NOERR) ) +!--------------------------- +END SUBROUTINE flinquery_var +!- +!=== +!- +SUBROUTINE flininspect (fid_in) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! fid : File id to inspect +!- + INTEGER :: fid_in +!- +!- LOCAL +!- + INTEGER :: iim, jjm, llm, ttm, fid_out + INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim + INTEGER :: iv, in, lll + INTEGER :: xid, yid, zid, tid + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid + CHARACTER(LEN=80) :: name + CHARACTER(LEN=30) :: axname +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, & + nAttributes=nb_atts, unlimitedDimId=id_unlim) +!- + WRITE (*,*) 'IOIPSL ID : ',fid_in + WRITE (*,*) 'NetCDF ID : ',fid + WRITE (*,*) 'Number of dimensions : ',ndims + WRITE (*,*) 'Number of variables : ',nvars + WRITE (*,*) 'Number of global attributes : ',nb_atts + WRITE (*,*) 'ID unlimited : ',id_unlim +!- + xid = -1; iim = 0; + yid = -1; jjm = 0; + zid = -1; llm = 0; + tid = -1; ttm = 0; +!- + DO iv=1,ndims +!--- + iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll) + CALL strlowercase (axname) + axname = ADJUSTL(axname) +!--- + WRITE (*,*) 'Dimension number : ',iv + WRITE (*,*) 'Dimension name : ',TRIM(axname) +!--- + IF ( (INDEX(axname,'x') == 1) & + .OR.(INDEX(axname,'lon') == 1)) THEN + xid = iv; iim = lll; + WRITE (*,*) 'Dimension X size : ',iim + ELSE IF ( (INDEX(axname,'y') == 1) & + .OR.(INDEX(axname,'lat') == 1)) THEN + yid = iv; jjm = lll; + WRITE (*,*) 'Dimension Y size : ',jjm + ELSE IF ( (INDEX(axname,'lev') == 1) & + .OR.(INDEX(axname,'plev') == 1) & + .OR.(INDEX(axname,'z') == 1) & + .OR.(INDEX(axname,'depth') == 1)) THEN + zid = iv; llm = lll; + WRITE (*,*) 'Dimension Z size : ',llm + ELSE IF ( (INDEX(axname,'tstep') == 1) & + .OR.(INDEX(axname,'time_counter') == 1)) THEN +!---- For the time we certainly need to allow for other names + tid = iv; ttm = lll; + ELSE IF (ndims == 1) THEN +!---- Nothing was found and ndims=1 then we have a vector of data + xid = 1; iim = lll; + ENDIF +!--- + ENDDO +!- +! Keep all this information +!- + nbfiles = nbfiles+1 +!- + IF (nbfiles > nbfile_max) THEN + CALL histerr(3,'flininspect', & + 'Too many files. Please increase nbfil_max', & + 'in program flincom.F90.',' ') + ENDIF +!- + ncids(nbfiles) = fid + ncnbd(nbfiles) = ndims +!- + ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /) +!- + ncfunli(nbfiles) = id_unlim + ncnba(nbfiles) = nb_atts + ncnbva(nbfiles) = nvars + ncfileopen(nbfiles) = .TRUE. +!- + fid_out = nbfiles +!- + DO in=1,nvars + iret = NF90_INQUIRE_VARIABLE (fid, in, & + name=name, ndims=ndims, dimids=idimid, nAtts=nb_atts) + WRITE (*,*) 'Variable number ------------ > ', in + WRITE (*,*) 'Variable name : ', TRIM(name) + WRITE (*,*) 'Number of dimensions : ', ndims + WRITE (*,*) 'Dimensions ID''s : ', idimid(1:ndims) + WRITE (*,*) 'Number of attributes : ', nb_atts + ENDDO +!------------------------- +END SUBROUTINE flininspect +!- +!=== +!- +END MODULE flincom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/d8/d8aba3ceea56ded2096d05d46ac1571c385e5763.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/d8/d8aba3ceea56ded2096d05d46ac1571c385e5763.svn-base new file mode 100644 index 0000000..7b9059e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/d8/d8aba3ceea56ded2096d05d46ac1571c385e5763.svn-base @@ -0,0 +1,755 @@ +/* parser config.in + * $Id$ + * + * This software is governed by the CeCILL license + * See IOIPSL/IOIPSL_License_CeCILL.txt + * + * Version 1.0 + * Eric Youngdale + * 10/95 + * + * The general idea here is that we want to parse a config.in file and + * from this, we generate a wish script which gives us effectively the + * same functionality that the original config.in script provided. + * + * This task is split roughly into 3 parts. The first parse is the parse + * of the input file itself. The second part is where we analyze the + * #ifdef clauses, and attach a linked list of tokens to each of the + * menu items. In this way, each menu item has a complete list of + * dependencies that are used to enable/disable the options. + * The third part is to take the configuration database we have build, + * and build the actual wish script. + * + * This file contains the code to do the first parse of config.in. + */ +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include "tkparse.h" + +struct kconfig * config = NULL; +struct kconfig * clast = NULL; +struct kconfig * koption = NULL; +static int lineno = 0; +static int menus_seen = 0; +static char * current_file = NULL; +static int do_source(char * filename); +static char * get_string(char *pnt, char ** labl); +static int choose_number = 0; + + +/* + * Simple function just to skip over spaces and tabs in config.in. + */ +static char * skip_whitespace(char * pnt) +{ + while( *pnt && (*pnt == ' ' || *pnt == '\t')) pnt++; + return pnt; +} + +/* + * This function parses a conditional from a config.in (i.e. from an ifdef) + * and generates a linked list of tokens that describes the conditional. + */ +static struct condition * parse_if(char * pnt) +{ + char * opnt; + struct condition *list; + struct condition *last; + struct condition *cpnt; + char varname[64]; + char * pnt1; + + opnt = pnt; + + /* + * We need to find the various tokens, and build the linked list. + */ + pnt = skip_whitespace(pnt); + if( *pnt != '[' ) return NULL; + pnt++; + pnt = skip_whitespace(pnt); + + list = last = NULL; + while(*pnt && *pnt != ']') { + + pnt = skip_whitespace(pnt); + if(*pnt== '\0' || *pnt == ']') break; + + /* + * Allocate memory for the token we are about to parse, and insert + * it in the linked list. + */ + cpnt = (struct condition *) malloc(sizeof(struct condition)); + memset(cpnt, 0, sizeof(struct condition)); + if( last == NULL ) + { + list = last = cpnt; + } + else + { + last->next = cpnt; + last = cpnt; + } + + /* + * Determine what type of operation this token represents. + */ + if( *pnt == '-' && pnt[1] == 'a' ) + { + cpnt->op = op_and; + pnt += 2; + continue; + } + + if( *pnt == '-' && pnt[1] == 'o' ) + { + cpnt->op = op_or; + pnt += 2; + continue; + } + + if( *pnt == '!' && pnt[1] == '=' ) + { + cpnt->op = op_neq; + pnt += 2; + continue; + } + + if( *pnt == '=') + { + cpnt->op = op_eq; + pnt += 1; + continue; + } + + if( *pnt == '!') + { + cpnt->op = op_bang; + pnt += 1; + continue; + } + + if( *pnt != '"' ) goto error; /* This cannot be right. */ + pnt++; + if( *pnt == '`' ) + { + cpnt->op = op_shellcmd; + pnt1 = varname; + pnt++; + while(*pnt && *pnt != '`') *pnt1++ = *pnt++; + *pnt1++ = '\0'; + cpnt->variable.str = strdup(varname); + if( *pnt == '`' ) pnt++; + if( *pnt == '"' ) pnt++; + continue; + } + if( *pnt == '$' ) + { + cpnt->op = op_variable; + pnt1 = varname; + pnt++; + while(*pnt && *pnt != '"') *pnt1++ = *pnt++; + *pnt1++ = '\0'; + cpnt->variable.str = strdup(varname); + if( *pnt == '"' ) pnt++; + continue; + } + + cpnt->op = op_constant; + pnt1 = varname; + while(*pnt && *pnt != '"') *pnt1++ = *pnt++; + *pnt1++ = '\0'; + cpnt->variable.str = strdup(varname); + if( *pnt == '"' ) pnt++; + continue; + } + + return list; + + error: + if(current_file != NULL) + fprintf(stderr, + "Bad if clause at line %d(%s):%s\n", lineno, current_file, opnt); + else + fprintf(stderr, + "Bad if clause at line %d:%s\n", lineno, opnt); + return NULL; +} + +/* + * This function looks for a quoted string, from the input buffer, and + * returns a pointer to a copy of this string. Any characters in + * the string that need to be "quoted" have a '\' character inserted + * in front - this way we can directly write these strings into + * wish scripts. + */ +static char * get_qstring(char *pnt, char ** labl) +{ + char quotechar; + char newlabel[1024]; + char * pnt1; + char * pnt2; + + while( *pnt && *pnt != '"' && *pnt != '\'') pnt++; + if (*pnt == '\0') return pnt; + + quotechar = *pnt++; + pnt1 = newlabel; + while(*pnt && *pnt != quotechar && pnt[-1] != '\\') + { + /* + * Quote the character if we need to. + */ + if( *pnt == '"' || *pnt == '\'' || *pnt == '[' || *pnt == ']') + *pnt1++ = '\\'; + + *pnt1++ = *pnt++; + } + *pnt1++ = '\0'; + + pnt2 = (char *) malloc(strlen(newlabel) + 1); + strcpy(pnt2, newlabel); + *labl = pnt2; + + /* + * Skip over last quote, and whitespace. + */ + pnt++; + pnt = skip_whitespace(pnt); + return pnt; +} + +static char * parse_choices(struct kconfig * choice_kcfg, char * pnt) +{ + struct kconfig * kcfg; + int index = 1; + + /* + * Choices appear in pairs of strings. The parse is fairly trivial. + */ + while(1) + { + pnt = skip_whitespace(pnt); + if(*pnt == '\0') break; + + kcfg = (struct kconfig *) malloc(sizeof(struct kconfig)); + memset(kcfg, 0, sizeof(struct kconfig)); + kcfg->tok = tok_choice; + if( clast != NULL ) + { + clast->next = kcfg; + clast = kcfg; + } + else + { + clast = config = kcfg; + } + + pnt = get_string(pnt, &kcfg->label); + pnt = skip_whitespace(pnt); + pnt = get_string(pnt, &kcfg->optionname); + kcfg->choice_label = choice_kcfg; + kcfg->choice_value = index++; + if( strcmp(kcfg->label, choice_kcfg->value) == 0 ) + choice_kcfg->choice_value = kcfg->choice_value; + } + + return pnt; +} + + +/* + * This function grabs one text token from the input buffer + * and returns a pointer to a copy of just the identifier. + * This can be either a variable name (i.e. CONFIG_NET), + * or it could be the default value for the option. + */ +static char * get_string(char *pnt, char ** labl) +{ + char newlabel[1024]; + char * pnt1; + char * pnt2; + + if (*pnt == '\0') return pnt; + + pnt1 = newlabel; + while(*pnt && *pnt != ' ' && *pnt != '\t') + { + *pnt1++ = *pnt++; + } + *pnt1++ = '\0'; + + pnt2 = (char *) malloc(strlen(newlabel) + 1); + strcpy(pnt2, newlabel); + *labl = pnt2; + + if( *pnt ) pnt++; + return pnt; +} + + +/* + * Top level parse function. Input pointer is one complete line from config.in + * and the result is that we create a token that describes this line + * and insert it into our linked list. + */ +void parse(char * pnt) { + enum token tok; + struct kconfig * kcfg; + char tmpbuf[24],fake_if[1024]; + + /* + * Ignore comments and leading whitespace. + */ + + pnt = skip_whitespace(pnt); + while( *pnt && (*pnt == ' ' || *pnt == '\t')) pnt++; + if(! *pnt ) return; + if( *pnt == '#' ) return; + + /* + * Now categorize the next token. + */ + tok = tok_unknown; + if (strncmp(pnt, "mainmenu_name", 13) == 0) + { + tok = tok_menuname; + pnt += 13; + } + else if (strncmp(pnt, "source", 6) == 0) + { + pnt += 7; + pnt = skip_whitespace(pnt); + do_source(pnt); + return; + } + else if (strncmp(pnt, "mainmenu_option", 15) == 0) + { + menus_seen++; + tok = tok_menuoption; + pnt += 15; + } + else if (strncmp(pnt, "$MAKE ", 6) == 0) + { + tok = tok_make; + } + else if (strncmp(pnt, "comment", 7) == 0) + { + tok = tok_comment; + pnt += 7; + } + else if (strncmp(pnt, "choice", 6) == 0) + { + tok = tok_choose; + pnt += 6; + } + else if (strncmp(pnt, "define_bool", 11) == 0) + { + tok = tok_define; + pnt += 11; + } + else if (strncmp(pnt, "bool", 4) == 0) + { + tok = tok_bool; + pnt += 4; + } + else if (strncmp(pnt, "tristate", 8) == 0) + { + tok = tok_tristate; + pnt += 8; + } + else if (strncmp(pnt, "dep_tristate", 12) == 0) + { + tok = tok_dep_tristate; + pnt += 12; + } + else if (strncmp(pnt, "int", 3) == 0) + { + tok = tok_int; + pnt += 3; + } + else if (strncmp(pnt, "hex", 3) == 0) + { + tok = tok_hex; + pnt += 3; + } + else if (strncmp(pnt, "if", 2) == 0) + { + tok = tok_if; + pnt += 2; + } + else if (strncmp(pnt, "else", 4) == 0) + { + tok = tok_else; + pnt += 4; + } + else if (strncmp(pnt, "fi", 2) == 0) + { + tok = tok_fi; + pnt += 2; + } + else if (strncmp(pnt, "endmenu", 7) == 0) + { + tok = tok_endmenu; + pnt += 7; + } + + if( tok == tok_unknown) + { + if( clast != NULL && clast->tok == tok_if + && strcmp(pnt,"then") == 0) return; + if( current_file != NULL ) + fprintf(stderr, "unknown command=%s(%s %d)\n", pnt, + current_file, lineno); + else + fprintf(stderr, "unknown command=%s(%d)\n", pnt,lineno); + return; + } + + /* + * Allocate memory for this item, and attach it to the end of the linked + * list. + */ + kcfg = (struct kconfig *) malloc(sizeof(struct kconfig)); + memset(kcfg, 0, sizeof(struct kconfig)); + kcfg->tok = tok; + if( clast != NULL ) + { + clast->next = kcfg; + clast = kcfg; + } + else + { + clast = config = kcfg; + } + + pnt = skip_whitespace(pnt); + + /* + * Now parse the remaining parts of the option, and attach the results + * to the structure. + */ + switch (tok) + { + case tok_choose: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_qstring(pnt, &kcfg->optionname); + pnt = get_string(pnt, &kcfg->value); + /* + * Now we need to break apart the individual options into their + * own configuration structures. + */ + parse_choices(kcfg, kcfg->optionname); + free(kcfg->optionname); + sprintf(tmpbuf, "tmpvar_%d", choose_number++); + kcfg->optionname = strdup(tmpbuf); + break; + case tok_define: + pnt = get_string(pnt, &kcfg->optionname); + if(*pnt == 'y' || *pnt == 'Y' ) kcfg->value = "1"; + if(*pnt == 'n' || *pnt == 'N' ) kcfg->value = "0"; + if(*pnt == 'm' || *pnt == 'M' ) kcfg->value = "2"; + break; + case tok_menuname: + pnt = get_qstring(pnt, &kcfg->label); + break; + case tok_bool: + case tok_tristate: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_string(pnt, &kcfg->optionname); + break; + case tok_int: + case tok_hex: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_string(pnt, &kcfg->optionname); + pnt = get_string(pnt, &kcfg->value); + break; + case tok_dep_tristate: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_string(pnt, &kcfg->optionname); + pnt = skip_whitespace(pnt); + if( *pnt == '$') pnt++; + pnt = get_string(pnt, &kcfg->depend.str); + + /* + * Create a conditional for this object's dependency. + * + * We can't use "!= n" because this is internally converted to "!= 0" + * and if UMSDOS depends on MSDOS which depends on FAT, then when FAT + * is disabled MSDOS has 16 added to its value, making UMSDOS fully + * available. Whew. + * + * This is more of a hack than a fix. Nested "if" conditionals are + * probably affected too - that +/- 16 affects things in too many + * places. But this should do for now. + */ + sprintf(fake_if,"[ \"$%s\" = \"y\" -o \"$%s\" = \"m\" ]; then", + kcfg->depend.str,kcfg->depend.str); + kcfg->cond = parse_if(fake_if); + if(kcfg->cond == NULL ) + { + exit(1); + } + break; + case tok_comment: + pnt = get_qstring(pnt, &kcfg->label); + if( koption != NULL ) + { + pnt = get_qstring(pnt, &kcfg->label); + koption->label = kcfg->label; + koption = NULL; + } + break; + case tok_menuoption: + if( strncmp(pnt, "next_comment", 12) == 0) + { + koption = kcfg; + } + else + { + pnt = get_qstring(pnt, &kcfg->label); + } + break; + case tok_make: + kcfg->value=strdup(pnt); + break; + case tok_else: + case tok_fi: + case tok_endmenu: + break; + case tok_if: + /* + * Conditionals are different. For the first level parse, only + * tok_if and tok_dep_tristate items have a ->cond chain attached. + */ + kcfg->cond = parse_if(pnt); + if(kcfg->cond == NULL ) + { + exit(1); + } + break; + default: + exit(0); + } + + return; +} + +/* + * Simple function to dump to the screen what the condition chain looks like. + */ +void dump_if(struct condition * cond) +{ + printf(" "); + while(cond != NULL ) + { + switch(cond->op){ + case op_eq: + printf(" = "); + break; + case op_bang: + printf(" ! "); + break; + case op_neq: + printf(" != "); + break; + case op_and: + printf(" -a "); + break; + case op_lparen: + printf("("); + break; + case op_rparen: + printf(")"); + break; + case op_variable: + printf("$%s", cond->variable.str); + break; + case op_constant: + printf("'%s'", cond->variable.str); + break; + default: + break; + } + cond = cond->next; + } + + printf("\n"); +} + +static int do_source(char * filename) +{ + char buffer[1024]; + int offset; + int old_lineno; + char * old_file; + char * pnt; + FILE * infile; + + if( strcmp(filename, "-") == 0 ) + infile = stdin; + else + infile = fopen(filename,"r"); + + /* + * If our cwd was in the scripts directory, we might have to go up one + * to find the sourced file. + */ + if(!infile) { + strcpy (buffer, "../"); + strcat (buffer, filename); + infile = fopen(buffer,"r"); + } + + if(!infile) { + fprintf(stderr,"Unable to open file %s\n", filename); + return 1; + } + old_lineno = lineno; + lineno = 0; + if( infile != stdin ) { + old_file = current_file; + current_file = filename; + } + offset = 0; + while(1) + { + fgets(&buffer[offset], sizeof(buffer) - offset, infile); + if(feof(infile)) break; + + /* + * Strip the trailing return character. + */ + pnt = buffer + strlen(buffer) - 1; + if( *pnt == '\n') *pnt-- = 0; + lineno++; + if( *pnt == '\\' ) + { + offset = pnt - buffer; + } + else + { + parse(buffer); + offset = 0; + } + } + fclose(infile); + if( infile != stdin ) { + current_file = old_file; + } + lineno = old_lineno; + return 0; +} + +int main(int argc, char * argv[]) +{ +#if 0 + char buffer[1024]; + char * pnt; + struct kconfig * cfg; + int i; +#endif + + /* + * Read stdin to get the top level script. + */ + do_source("-"); + + if( menus_seen == 0 ) + { + fprintf(stderr,"The config.in file for this platform does not support\n"); + fprintf(stderr,"menus.\n"); + exit(1); + } + /* + * Input file is now parsed. Next we need to go through and attach + * the correct conditions to each of the actual menu items and kill + * the if/else/endif tokens from the list. We also flag the menu items + * that have other things that depend upon its setting. + */ + fix_conditionals(config); + + /* + * Finally, we generate the wish script. + */ + dump_tk_script(config); + +#if 0 + /* + * Now dump what we have so far. This is only for debugging so that + * we can display what we think we have in the list. + */ + for(cfg = config; cfg; cfg = cfg->next) + { + + if(cfg->cond != NULL && cfg->tok != tok_if) + dump_if(cfg->cond); + + switch(cfg->tok) + { + case tok_menuname: + printf("main_menuname "); + break; + case tok_bool: + printf("bool "); + break; + case tok_tristate: + printf("tristate "); + break; + case tok_dep_tristate: + printf("dep_tristate "); + break; + case tok_int: + printf("int "); + break; + case tok_hex: + printf("hex "); + break; + case tok_comment: + printf("comment "); + break; + case tok_menuoption: + printf("menuoption "); + break; + case tok_else: + printf("else"); + break; + case tok_fi: + printf("fi"); + break; + case tok_if: + printf("if"); + break; + default: + } + + switch(cfg->tok) + { + case tok_menuoption: + case tok_comment: + case tok_menuname: + printf("%s\n", cfg->label); + break; + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + printf("%s %s\n", cfg->label, cfg->optionname); + break; + case tok_if: + dump_if(cfg->cond); + break; + case tok_nop: + case tok_endmenu: + break; + default: + printf("\n"); + } + } +#endif + + return 0; + +} diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/da/da61cd01d70ca49f538a560d1625d5335c58a371.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/da/da61cd01d70ca49f538a560d1625d5335c58a371.svn-base new file mode 100644 index 0000000..b413691 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/da/da61cd01d70ca49f538a560d1625d5335c58a371.svn-base @@ -0,0 +1,2008 @@ +MODULE getincom +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE errioipsl, ONLY : ipslerr +USE stringop, & + & ONLY : nocomma,cmpblank,strlowercase +!- +IMPLICIT NONE +!- +PRIVATE +PUBLIC :: getin_name, getin, getin_dump +!- +!!-------------------------------------------------------------------- +!! The "getin_name" routine allows the user to change the name +!! of the definition file in which the data will be read. +!! ("run.def" by default) +!! +!! SUBROUTINE getin_name (file_name) +!! +!! OPTIONAL INPUT argument +!! +!! (C) file_name : the name of the file +!! in which the data will be read +!!-------------------------------------------------------------------- +!- +!- +INTERFACE getin +!!-------------------------------------------------------------------- +!! The "getin" routines get a variable. +!! We first check if we find it in the database +!! and if not we get it from the definition file. +!! +!! SUBROUTINE getin (target,ret_val) +!! +!! INPUT +!! +!! (C) target : Name of the variable +!! +!! OUTPUT +!! +!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain +!! that will contain the (standard) +!! integer/real/character/logical values +!!-------------------------------------------------------------------- + MODULE PROCEDURE getinrs, getinr1d, getinr2d, & + & getinis, getini1d, getini2d, & + & getincs, getinc1d, getinc2d, & + & getinls, getinl1d, getinl2d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "getin_dump" routine will dump the content of the database +!! into a file which has the same format as the definition file. +!! The idea is that the user can see which parameters were used +!! and re-use the file for another run. +!! +!! SUBROUTINE getin_dump (fileprefix) +!! +!! OPTIONAL INPUT argument +!! +!! (C) fileprefix : allows the user to change the name of the file +!! in which the data will be archived +!!-------------------------------------------------------------------- +!- + INTEGER,PARAMETER :: max_files=100 + CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist + INTEGER,SAVE :: nbfiles +!- + INTEGER,SAVE :: allread=0 + CHARACTER(LEN=100),SAVE :: def_file = 'run.def' +!- + INTEGER,PARAMETER :: i_txtslab=1000,l_n=30 + INTEGER,SAVE :: nb_lines,i_txtsize=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier + CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline +!- + INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 + CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)' +!- +! The data base of parameters +!- + INTEGER,PARAMETER :: memslabs=200 + INTEGER,PARAMETER :: compress_lim=20 +!- + INTEGER,SAVE :: nb_keys=0 + INTEGER,SAVE :: keymemsize=0 +!- +! keystr definition +! name of a key +!- +! keystatus definition +! keystatus = 1 : Value comes from the file defined by 'def_file' +! keystatus = 2 : Default value is used +! keystatus = 3 : Some vector elements were taken from default +!- +! keytype definition +! keytype = 1 : Integer +! keytype = 2 : Real +! keytype = 3 : Character +! keytype = 4 : Logical +!- + INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 +!- +! Allow compression for keys (only for integer and real) +! keycompress < 0 : not compressed +! keycompress > 0 : number of repeat of the value +!- +TYPE :: t_key + CHARACTER(LEN=l_n) :: keystr + INTEGER :: keystatus, keytype, keycompress, & + & keyfromfile, keymemstart, keymemlen +END TYPE t_key +!- + TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab +!- + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem + INTEGER,SAVE :: i_memsize=0, i_mempos=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem + INTEGER,SAVE :: r_memsize=0, r_mempos=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem + INTEGER,SAVE :: c_memsize=0, c_mempos=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem + INTEGER,SAVE :: l_memsize=0, l_mempos=0 +!- +CONTAINS +!- +!=== DEFINITION FILE NAME INTERFACE +!- +SUBROUTINE getin_name (cname) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: cname +!--------------------------------------------------------------------- + IF (allread == 0) THEN + def_file = ADJUSTL(cname) + ELSE + CALL ipslerr (3,'getin_name', & + & 'The name of the database file (any_name.def)', & + & 'must be changed *before* any attempt','to read the database.') + ENDIF +!------------------------ +END SUBROUTINE getin_name +!- +!=== INTEGER INTERFACE +!- +SUBROUTINE getinis (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: ret_val +!- + INTEGER,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,i_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinis +!=== +SUBROUTINE getini1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getini1d +!=== +SUBROUTINE getini2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:,:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getini2d +!- +!=== REAL INTERFACE +!- +SUBROUTINE getinrs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL :: ret_val +!- + REAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,r_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinrs +!=== +SUBROUTINE getinr1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinr1d +!=== +SUBROUTINE getinr2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:,:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinr2d +!- +!=== CHARACTER INTERFACE +!- +SUBROUTINE getincs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,c_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getincs +!=== +SUBROUTINE getinc1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinc1d +!=== +SUBROUTINE getinc2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinc2d +!- +!=== LOGICAL INTERFACE +!- +SUBROUTINE getinls (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL :: ret_val +!- + LOGICAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,l_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinls +!=== +SUBROUTINE getinl1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinl1d +!=== +SUBROUTINE getinl2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:,:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinl2d +!- +!=== Generic file/database INTERFACE +!- +SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Subroutine that will extract from the file the values +!- attributed to the keyword target +!- +!- (C) target : target for which we will look in the file +!- (I) status : tells us from where we obtained the data +!- (I) fileorig : index of the file from which the key comes +!- (I) i_val(:) : INTEGER(nb_to_ret) values +!- (R) r_val(:) : REAL(nb_to_ret) values +!- (L) l_val(:) : LOGICAL(nb_to_ret) values +!- (C) c_val(:) : CHARACTER(nb_to_ret) values +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,INTENT(OUT) :: status,fileorig + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=80) :: str_READ,str_READ_lower + CHARACTER(LEN=9) :: c_vtyp + LOGICAL,DIMENSION(:),ALLOCATABLE :: found + LOGICAL :: def_beha,compressed + CHARACTER(LEN=10) :: c_fmt + INTEGER :: i_cmpval + REAL :: r_cmpval + INTEGER :: ipos_tr,ipos_fl +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + SELECT CASE (k_typ) + CASE(k_i) + nb_to_ret = SIZE(i_val) + CASE(k_r) + nb_to_ret = SIZE(r_val) + CASE(k_c) + nb_to_ret = SIZE(c_val) + CASE(k_l) + nb_to_ret = SIZE(l_val) + CASE DEFAULT + CALL ipslerr (3,'get_fil', & + & 'Internal error','Unknown type of data',' ') + END SELECT +!- +! Read the file(s) + CALL getin_read +!- +! Allocate and initialize the memory we need + ALLOCATE(found(nb_to_ret)) + found(:) = .FALSE. +!- +! See what we find in the files read + DO it=1,nb_to_ret +!--- +!-- First try the target as it is + CALL get_findkey (2,target,pos) +!--- +!-- Another try +!--- + IF (pos < 0) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + CALL get_findkey (2,TRIM(target)//'__'//cnt,pos) + ENDIF +!--- +!-- We dont know from which file the target could come. +!-- Thus by default we attribute it to the first file : + fileorig = 1 +!--- + IF (pos > 0) THEN +!----- + found(it) = .TRUE. + fileorig = fromfile(pos) +!----- +!---- DECODE +!----- + str_READ = ADJUSTL(fichier(pos)) + str_READ_lower = str_READ + CALL strlowercase (str_READ_lower) +!----- + IF ( (TRIM(str_READ_lower) == 'def') & + & .OR.(TRIM(str_READ_lower) == 'default') ) THEN + def_beha = .TRUE. + ELSE + def_beha = .FALSE. + len_str = LEN_TRIM(str_READ) + io_err = 0 + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str + READ (UNIT=str_READ(1:len_str), & + & FMT=c_fmt,IOSTAT=io_err) i_val(it) + CASE(k_r) + READ (UNIT=str_READ(1:len_str), & + & FMT=*,IOSTAT=io_err) r_val(it) + CASE(k_c) + c_val(it) = str_READ(1:len_str) + CASE(k_l) + ipos_tr = -1 + ipos_fl = -1 + ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & + & INDEX(str_READ_lower,'y')) + ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & + & INDEX(str_READ_lower,'n')) + IF (ipos_tr > 0) THEN + l_val(it) = .TRUE. + ELSE IF (ipos_fl > 0) THEN + l_val(it) = .FALSE. + ELSE + io_err = 100 + ENDIF + END SELECT + IF (io_err /= 0) THEN + CALL ipslerr (3,'get_fil', & + & 'Target '//TRIM(target), & + & 'is not of '//TRIM(c_vtyp)//' type',' ') + ENDIF + ENDIF +!----- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!------- +!------ Is this the value of a compressed field ? + compressed = (compline(pos) > 0) + IF (compressed) THEN + IF (compline(pos) /= nb_to_ret) THEN + CALL ipslerr (2,'get_fil', & + & 'For key '//TRIM(target)//' we have a compressed field', & + & 'which does not have the right size.', & + & 'We will try to fix that.') + ENDIF + IF (k_typ == k_i) THEN + i_cmpval = i_val(it) + ELSE IF (k_typ == k_r) THEN + r_cmpval = r_val(it) + ENDIF + ENDIF + ENDIF + ELSE + found(it) = .FALSE. + def_beha = .FALSE. + compressed = .FALSE. + ENDIF + ENDDO +!- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!--- +!-- If this is a compressed field then we will uncompress it + IF (compressed) THEN + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + IF (k_typ == k_i) THEN + i_val(it) = i_cmpval + ELSE IF (k_typ == k_r) THEN + ENDIF + found(it) = .TRUE. + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Now we set the status for what we found + IF (def_beha) THEN + status = 2 + WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target) + ELSE + status_cnt = 0 + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + status_cnt = status_cnt+1 + IF (status_cnt <= max_msgs) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & + & ADVANCE='NO') TRIM(target) + IF (nb_to_ret > 1) THEN + WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') + WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it + ENDIF + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=*,FMT=*) "=",i_val(it) + CASE(k_r) + WRITE (UNIT=*,FMT=*) "=",r_val(it) + CASE(k_c) + WRITE (UNIT=*,FMT=*) "=",c_val(it) + CASE(k_l) + WRITE (UNIT=*,FMT=*) "=",l_val(it) + END SELECT + ELSE IF (status_cnt == max_msgs+1) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)') + ENDIF + ENDIF + ENDDO +!--- + IF (status_cnt == 0) THEN + status = 1 + ELSE IF (status_cnt == nb_to_ret) THEN + status = 2 + ELSE + status = 3 + ENDIF + ENDIF +! Deallocate the memory + DEALLOCATE(found) +!--------------------- +END SUBROUTINE get_fil +!=== +SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Read the required variable in the database +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: pos,size_of_in + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,k_beg,k_end + CHARACTER(LEN=9) :: c_vtyp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_rdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- + IF (key_tab(pos)%keytype /= k_typ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong data type for keyword '//TRIM(target), & + & '(NOT '//TRIM(c_vtyp)//')',' ') + ENDIF +!- + IF (key_tab(pos)%keycompress > 0) THEN + IF ( (key_tab(pos)%keycompress /= size_of_in) & + & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong compression length','for keyword '//TRIM(target),' ') + ELSE + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart) + CASE(k_r) + r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart) + END SELECT + ENDIF + ELSE + IF (key_tab(pos)%keymemlen /= size_of_in) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong array length','for keyword '//TRIM(target),' ') + ELSE + k_beg = key_tab(pos)%keymemstart + k_end = k_beg+key_tab(pos)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(k_beg:k_end) + CASE(k_r) + r_val(1:size_of_in) = r_mem(k_beg:k_end) + CASE(k_c) + c_val(1:size_of_in) = c_mem(k_beg:k_end) + CASE(k_l) + l_val(1:size_of_in) = l_mem(k_beg:k_end) + END SELECT + ENDIF + ENDIF +!--------------------- +END SUBROUTINE get_rdb +!=== +SUBROUTINE get_wdb & + & (target,status,fileorig,size_of_in, & + & i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Write data into the data base +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: status,fileorig,size_of_in + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ + CHARACTER(LEN=9) :: c_vtyp + INTEGER :: k_mempos,k_memsize,k_beg,k_end + LOGICAL :: l_cmp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_wdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- +! First check if we have sufficiant space for the new key + IF (nb_keys+1 > keymemsize) THEN + CALL getin_allockeys () + ENDIF +!- + SELECT CASE (k_typ) + CASE(k_i) + k_mempos = i_mempos; k_memsize = i_memsize; + l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_r) + k_mempos = r_mempos; k_memsize = r_memsize; + l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_c) + k_mempos = c_mempos; k_memsize = c_memsize; + l_cmp = .FALSE. + CASE(k_l) + k_mempos = l_mempos; k_memsize = l_memsize; + l_cmp = .FALSE. + END SELECT +!- +! Fill out the items of the data base + nb_keys = nb_keys+1 + key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n)) + key_tab(nb_keys)%keystatus = status + key_tab(nb_keys)%keytype = k_typ + key_tab(nb_keys)%keyfromfile = fileorig + key_tab(nb_keys)%keymemstart = k_mempos+1 + IF (l_cmp) THEN + key_tab(nb_keys)%keycompress = size_of_in + key_tab(nb_keys)%keymemlen = 1 + ELSE + key_tab(nb_keys)%keycompress = -1 + key_tab(nb_keys)%keymemlen = size_of_in + ENDIF +!- +! Before writing the actual size lets see if we have the space + IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & + & > k_memsize) THEN + CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) + ENDIF +!- + k_beg = key_tab(nb_keys)%keymemstart + k_end = k_beg+key_tab(nb_keys)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen) + i_mempos = k_end + CASE(k_r) + r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen) + r_mempos = k_end + CASE(k_c) + c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen) + c_mempos = k_end + CASE(k_l) + l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen) + l_mempos = k_end + END SELECT +!--------------------- +END SUBROUTINE get_wdb +!- +!=== +!- +SUBROUTINE getin_read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,SAVE :: current +!--------------------------------------------------------------------- + IF (allread == 0) THEN +!-- Allocate a first set of memory. + CALL getin_alloctxt () + CALL getin_allockeys () + CALL getin_allocmem (k_i,0) + CALL getin_allocmem (k_r,0) + CALL getin_allocmem (k_c,0) + CALL getin_allocmem (k_l,0) +!-- Start with reading the files + nbfiles = 1 + filelist(1) = TRIM(def_file) + current = 1 +!-- + DO WHILE (current <= nbfiles) + CALL getin_readdef (current) + current = current+1 + ENDDO + allread = 1 + CALL getin_checkcohe () + ENDIF +!------------------------ +END SUBROUTINE getin_read +!- +!=== +!- + SUBROUTINE getin_readdef(current) +!--------------------------------------------------------------------- +!- This subroutine will read the files and only keep the +!- the relevant information. The information is kept as it +!- found in the file. The data will be analysed later. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: current +!- + CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt + INTEGER :: nb_lastkey +!- + INTEGER :: eof,ptn,len_str,i,it,iund,io_err + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + eof = 0 + ptn = 1 + nb_lastkey = 0 +!- + IF (check) THEN + WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) + ENDIF +!- + OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err) + IF (io_err /= 0) THEN + CALL ipslerr (2,'getin_readdef', & + & 'Could not open file '//TRIM(filelist(current)),' ',' ') + RETURN + ENDIF +!- + DO WHILE (eof /= 1) +!--- + CALL getin_skipafew (22,READ_str,eof,nb_lastkey) + len_str = LEN_TRIM(READ_str) + ptn = INDEX(READ_str,'=') +!--- + IF (ptn > 0) THEN +!---- Get the target + key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) +!---- Make sure that a vector keyword has the right length + iund = INDEX(key_str,'__') + IF (iund > 0) THEN + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & + & LEN_TRIM(key_str)-iund-1 + READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & + & FMT=c_fmt,IOSTAT=io_err) it + IF ( (io_err == 0).AND.(it > 0) ) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + key_str = key_str(1:iund+1)//cnt + ELSE + CALL ipslerr (3,'getin_readdef', & + & 'A very strange key has just been found :', & + & TRIM(key_str),' ') + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str))) + CALL nocomma (NEW_str) + CALL cmpblank (NEW_str) + NEW_str = TRIM(ADJUSTL(NEW_str)) + IF (check) THEN + WRITE(*,*) & + & '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) + ENDIF +!---- Decypher the content of NEW_str +!- +!---- This has to be a new key word, thus : + nb_lastkey = 0 +!---- + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) +!---- + ELSE IF (len_str > 0) THEN +!---- Prepare the key if we have an old one to which +!---- we will add the line just read + IF (nb_lastkey > 0) THEN + iund = INDEX(last_key,'__') + IF (iund > 0) THEN +!-------- We only continue a keyword, thus it is easy + key_str = last_key(1:iund-1) + ELSE + IF (nb_lastkey /= 1) THEN + CALL ipslerr (3,'getin_readdef', & + & 'We can not have a scalar keyword', & + & 'and a vector content',' ') + ENDIF +!-------- The last keyword needs to be transformed into a vector. + WRITE(UNIT=cnt,FMT=c_i_fmt) 1 + targetlist(nb_lines) = & + & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt + key_str = last_key(1:LEN_TRIM(last_key)) + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(1:len_str))) + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) + ELSE +!---- If we have an empty line then the keyword finishes + nb_lastkey = 0 + IF (check) THEN + WRITE(*,*) 'getin_readdef : Have found an emtpy line ' + ENDIF + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + IF (check) THEN + OPEN (UNIT=22,file=TRIM(def_file)//'.test') + DO i=1,nb_lines + WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i) + ENDDO + CLOSE(UNIT=22) + ENDIF +!--------------------------- +END SUBROUTINE getin_readdef +!- +!=== +!- +SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey) +!--------------------------------------------------------------------- +!- This subroutine is going to decypher the line. +!- It essentialy checks how many items are included and +!- it they can be attached to a key. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: current,nb_lastkey + CHARACTER(LEN=*) :: key_str,NEW_str,last_key +!- +! LOCAL +!- + INTEGER :: len_str,blk,nbve,starpos + CHARACTER(LEN=100) :: tmp_str,new_key,mult + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt +!--------------------------------------------------------------------- + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + tmp_str = NEW_str(1:len_str) +!- +! If the key is a new file then we take it up. Else +! we save the line and go on. +!- + IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN + DO WHILE (blk > 0) + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!----- + nbfiles = nbfiles+1 + filelist(nbfiles) = tmp_str(1:blk) +!----- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ') + ENDDO +!--- + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!--- + nbfiles = nbfiles+1 + filelist(nbfiles) = TRIM(ADJUSTL(tmp_str)) +!--- + last_key = 'INCLUDEDEF' + nb_lastkey = 1 + ELSE +!- +!-- We are working on a new line of input +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 +!- +!-- First we solve the issue of conpressed information. Once +!-- this is done all line can be handled in the same way. +!- + starpos = INDEX(NEW_str(1:len_str),'*') + IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & + & .AND.(tmp_str(1:1) /= "'") ) THEN +!----- + IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We can not have a compressed field of values', & + & 'in a vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str)) + ENDIF +!- +!---- Read the multiplied +!- + mult = TRIM(ADJUSTL(NEW_str(1:starpos-1))) +!---- Construct the new string and its parameters + NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str))) + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + IF (blk > 1) THEN + CALL ipslerr (2,'getin_decrypt', & + & 'This is a strange behavior','you could report',' ') + ENDIF + WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) + READ(UNIT=mult,FMT=c_fmt) compline(nb_lines) +!--- + ELSE + compline(nb_lines) = -1 + ENDIF +!- +!-- If there is no space wthin the line then the target is a scalar +!-- or the element of a properly written vector. +!-- (ie of the type TARGET__00001) +!- + IF ( (blk <= 1) & + & .OR.(tmp_str(1:1) == '"') & + & .OR.(tmp_str(1:1) == "'") ) THEN +!- + IF (nb_lastkey == 0) THEN +!------ Save info of current keyword as a scalar +!------ if it is not a continuation + targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + nb_lastkey = 1 + ELSE +!------ We are continuing a vector so the keyword needs +!------ to get the underscores + WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 + targetlist(nb_lines) = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nb_lastkey+1 + ENDIF +!----- + fichier(nb_lines) = NEW_str(1:len_str) + fromfile(nb_lines) = current + ELSE +!- +!---- If there are blanks whithin the line then we are dealing +!---- with a vector and we need to split it in many entries +!---- with the TARGET__n notation. +!---- +!---- Test if the targer is not already a vector target ! +!- + IF (INDEX(TRIM(key_str),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We have found a mixed vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str),' ') + ENDIF +!- + nbve = nb_lastkey + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + DO WHILE (blk > 0) +!- +!------ Save the content of target__nbve +!- + fichier(nb_lines) = tmp_str(1:blk) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(TRIM(tmp_str),' ') +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + ENDDO +!- +!---- Save the content of the last target +!- + fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nbve +!- + ENDIF +!- + ENDIF +!--------------------------- +END SUBROUTINE getin_decrypt +!- +!=== +!- +SUBROUTINE getin_checkcohe () +!--------------------------------------------------------------------- +!- This subroutine checks for redundancies. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: line,n_k,k +!--------------------------------------------------------------------- + DO line=1,nb_lines-1 +!- + n_k = 0 + DO k=line+1,nb_lines + IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN + n_k = k + EXIT + ENDIF + ENDDO +!--- +!-- IF we have found it we have a problem to solve. +!--- + IF (n_k > 0) THEN + WRITE(*,*) 'COUNT : ',n_k + WRITE(*,*) & + & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) + WRITE(*,*) & + & 'getin_checkcohe : The following values were encoutered :' + WRITE(*,*) & + & ' ',TRIM(targetlist(line)),' == ',fichier(line) + WRITE(*,*) & + & ' ',TRIM(targetlist(k)),' == ',fichier(k) + WRITE(*,*) & + & 'getin_checkcohe : We will keep only the last value' + targetlist(line) = ' ' + ENDIF + ENDDO +!----------------------------- +END SUBROUTINE getin_checkcohe +!- +!=== +!- +SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: unit,eof,nb_lastkey + CHARACTER(LEN=100) :: dummy + CHARACTER(LEN=100) :: out_string + CHARACTER(LEN=1) :: first +!--------------------------------------------------------------------- + first="#" + eof = 0 + out_string = " " +!- + DO WHILE (first == "#") + READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy + dummy = TRIM(ADJUSTL(dummy)) + first=dummy(1:1) + IF (first == "#") THEN + nb_lastkey = 0 + ENDIF + ENDDO + out_string=dummy +!- + RETURN +!- +9998 CONTINUE + CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ') +!- +7778 CONTINUE + eof = 1 +!---------------------------- +END SUBROUTINE getin_skipafew +!- +!=== +!- +SUBROUTINE getin_allockeys () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + IF (keymemsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp,FMT=*) memslabs + ALLOCATE(key_tab(memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + nb_keys = 0 + keymemsize = memslabs + key_tab(:)%keycompress = -1 +!--- + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp,FMT=*) keymemsize + ALLOCATE(tmp_key_tab(keymemsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate tmp_key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs + tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize) + DEALLOCATE(key_tab) + ALLOCATE(key_tab(keymemsize+memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + key_tab(:)%keycompress = -1 + key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize) + DEALLOCATE(tmp_key_tab) + keymemsize = keymemsize+memslabs + ENDIF +!----------------------------- +END SUBROUTINE getin_allockeys +!- +!=== +!- +SUBROUTINE getin_allocmem (type,len_wanted) +!--------------------------------------------------------------------- +!- Allocate the memory of the data base for all 4 types of memory +!- INTEGER / REAL / CHARACTER / LOGICAL +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: type,len_wanted +!- + INTEGER,ALLOCATABLE :: tmp_int(:) + REAL,ALLOCATABLE :: tmp_real(:) + CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) + LOGICAL,ALLOCATABLE :: tmp_logic(:) + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + SELECT CASE (type) + CASE(k_i) + IF (i_memsize == 0) THEN + ALLOCATE(i_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_memsize=memslabs + ELSE + ALLOCATE(tmp_int(i_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_int(1:i_memsize) = i_mem(1:i_memsize) + DEALLOCATE(i_mem) + ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_mem(1:i_memsize) = tmp_int(1:i_memsize) + i_memsize = i_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_int) + ENDIF + CASE(k_r) + IF (r_memsize == 0) THEN + ALLOCATE(r_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_memsize = memslabs + ELSE + ALLOCATE(tmp_real(r_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_real', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_real(1:r_memsize) = r_mem(1:r_memsize) + DEALLOCATE(r_mem) + ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_mem(1:r_memsize) = tmp_real(1:r_memsize) + r_memsize = r_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_real) + ENDIF + CASE(k_c) + IF (c_memsize == 0) THEN + ALLOCATE(c_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_memsize = memslabs + ELSE + ALLOCATE(tmp_char(c_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_char', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_char(1:c_memsize) = c_mem(1:c_memsize) + DEALLOCATE(c_mem) + ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_mem(1:c_memsize) = tmp_char(1:c_memsize) + c_memsize = c_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_char) + ENDIF + CASE(k_l) + IF (l_memsize == 0) THEN + ALLOCATE(l_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_memsize = memslabs + ELSE + ALLOCATE(tmp_logic(l_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_logic', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_logic(1:l_memsize) = l_mem(1:l_memsize) + DEALLOCATE(l_mem) + ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_mem(1:l_memsize) = tmp_logic(1:l_memsize) + l_memsize = l_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_logic) + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ') + END SELECT +!---------------------------- +END SUBROUTINE getin_allocmem +!- +!=== +!- +SUBROUTINE getin_alloctxt () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:) + CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:) + INTEGER,ALLOCATABLE :: tmp_int(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp1,c_tmp2 +!--------------------------------------------------------------------- + IF (i_txtsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtslab + ALLOCATE(fichier(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(targetlist(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(fromfile(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(compline(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + nb_lines = 0 + i_txtsize = i_txtslab + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtsize + WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab + ALLOCATE(tmp_fic(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_fic', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_fic(1:i_txtsize) = fichier(1:i_txtsize) + DEALLOCATE(fichier) + ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fichier(1:i_txtsize) = tmp_fic(1:i_txtsize) + DEALLOCATE(tmp_fic) +!--- + ALLOCATE(tmp_tgl(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_tgl', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize) + DEALLOCATE(targetlist) + ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize) + DEALLOCATE(tmp_tgl) +!--- + ALLOCATE(tmp_int(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_int(1:i_txtsize) = fromfile(1:i_txtsize) + DEALLOCATE(fromfile) + ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fromfile(1:i_txtsize) = tmp_int(1:i_txtsize) +!--- + tmp_int(1:i_txtsize) = compline(1:i_txtsize) + DEALLOCATE(compline) + ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + compline(1:i_txtsize) = tmp_int(1:i_txtsize) + DEALLOCATE(tmp_int) +!--- + i_txtsize = i_txtsize+i_txtslab + ENDIF +!---------------------------- +END SUBROUTINE getin_alloctxt +!- +!=== +!- +SUBROUTINE getin_dump (fileprefix) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(*),OPTIONAL :: fileprefix +!- + CHARACTER(LEN=80) :: usedfileprefix + INTEGER :: ikey,if,iff,iv + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=100) :: tmp_str,used_filename + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (PRESENT(fileprefix)) THEN + usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80)) + ELSE + usedfileprefix = "used" + ENDIF +!- + DO if=1,nbfiles +!--- + used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if)) + IF (check) THEN + WRITE(*,*) & + & 'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if + WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys + ENDIF + OPEN (UNIT=22,FILE=used_filename) +!--- +!-- If this is the first file we need to add the list +!-- of file which belong to it + IF ( (if == 1).AND.(nbfiles > 1) ) THEN + WRITE(22,*) '# ' + WRITE(22,*) '# This file is linked to the following files :' + WRITE(22,*) '# ' + DO iff=2,nbfiles + WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) + ENDDO + WRITE(22,*) '# ' + ENDIF +!--- + DO ikey=1,nb_keys +!----- +!---- Is this key from this file ? + IF (key_tab(ikey)%keyfromfile == if) THEN +!------- +!------ Write some comments + WRITE(22,*) '#' + SELECT CASE (key_tab(ikey)%keystatus) + CASE(1) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file) + CASE(2) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' are all defaults.' + CASE(3) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr), & + & ' are a mix of ',TRIM(def_file),' and defaults.' + CASE DEFAULT + WRITE(22,*) '# Dont know from where the value of ', & + & TRIM(key_tab(ikey)%keystr),' comes.' + END SELECT + WRITE(22,*) '#' +!------- +!------ Write the values + SELECT CASE (key_tab(ikey)%keytype) + CASE(k_i) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',i_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',i_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',i_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_r) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',r_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',r_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',r_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_c) + IF (key_tab(ikey)%keymemlen == 1) THEN + tmp_str = c_mem(key_tab(ikey)%keymemstart) + WRITE(22,*) TRIM(key_tab(ikey)%keystr), & + & ' = ',TRIM(tmp_str) + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',TRIM(tmp_str) + ENDDO + ENDIF + CASE(k_l) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (l_mem(key_tab(ikey)%keymemstart)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE ' + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = FALSE ' + ENDIF + ENDDO + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_dump', & + & 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & + & ' ',' ') + END SELECT + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + ENDDO +!------------------------ +END SUBROUTINE getin_dump +!=== +SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v) +!--------------------------------------------------------------------- +!- Returns the type of the argument (mutually exclusive) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: k_typ + CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp + INTEGER,DIMENSION(:),OPTIONAL :: i_v + REAL,DIMENSION(:),OPTIONAL :: r_v + LOGICAL,DIMENSION(:),OPTIONAL :: l_v + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v +!--------------------------------------------------------------------- + k_typ = 0 + IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & + & /= 1) THEN + CALL ipslerr (3,'get_qtyp', & + & 'Invalid number of optional arguments','(/= 1)',' ') + ENDIF +!- + IF (PRESENT(i_v)) THEN + k_typ = k_i + c_vtyp = 'INTEGER' + ELSEIF (PRESENT(r_v)) THEN + k_typ = k_r + c_vtyp = 'REAL' + ELSEIF (PRESENT(c_v)) THEN + k_typ = k_c + c_vtyp = 'CHARACTER' + ELSEIF (PRESENT(l_v)) THEN + k_typ = k_l + c_vtyp = 'LOGICAL' + ENDIF +!---------------------- +END SUBROUTINE get_qtyp +!=== +SUBROUTINE get_findkey (i_tab,c_key,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a key in a table +!--------------------------------------------------------------------- +!- INPUT +!- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr +!- 2 -> search in targetlist(1:nb_lines) +!- c_key : Name of the key we are looking for +!- OUTPUT +!- pos : -1 if key not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: i_tab + CHARACTER(LEN=*),INTENT(in) :: c_key + INTEGER,INTENT(out) :: pos +!- + INTEGER :: ikey_max,ikey + CHARACTER(LEN=l_n) :: c_q_key +!--------------------------------------------------------------------- + pos = -1 + IF (i_tab == 1) THEN + ikey_max = nb_keys + ELSEIF (i_tab == 2) THEN + ikey_max = nb_lines + ELSE + ikey_max = 0 + ENDIF + IF ( ikey_max > 0 ) THEN + DO ikey=1,ikey_max + IF (i_tab == 1) THEN + c_q_key = key_tab(ikey)%keystr + ELSE + c_q_key = targetlist(ikey) + ENDIF + IF (TRIM(c_q_key) == TRIM(c_key)) THEN + pos = ikey + EXIT + ENDIF + ENDDO + ENDIF +!------------------------- +END SUBROUTINE get_findkey +!=== +!------------------ +END MODULE getincom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/df/dfa9331e300df430363a69fa46ed04e8c6eb446d.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/df/dfa9331e300df430363a69fa46ed04e8c6eb446d.svn-base new file mode 100644 index 0000000..9f34d48 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/df/dfa9331e300df430363a69fa46ed04e8c6eb446d.svn-base @@ -0,0 +1,124 @@ +MODULE nc4interface +!- +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +#if ! defined key_netcdf4 + !!-------------------------------------------------------------------- + !! 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 +#else + !!-------------------------------------------------------------------- + !! 'key_netcdf4' Dummy module (usually defines dummy routines for netcdf4 + !! calls when compiling without netcdf4 libraries + !!-------------------------------------------------------------------- + + USE netcdf + + !- 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 + INTEGER FUNCTION SET_NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_CHUNKING *** + !! + !! ** Purpose : Interface NetCDF4 routine to enable compiling with NetCDF4 libraries + !! but no key_netcdf4 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: nfid + INTEGER, INTENT(in) :: nvid + INTEGER, INTENT(in) :: ichunkalg + INTEGER, DIMENSION(:), INTENT(in) :: ichunksz + !! + INTEGER :: iret + !! + iret = NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) + SET_NF90_DEF_VAR_CHUNKING = iret + END FUNCTION SET_NF90_DEF_VAR_CHUNKING + + INTEGER FUNCTION SET_NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_DEFLATE *** + !! + !! ** Purpose : Interface NetCDF4 routine to enable compiling with NetCDF4 libraries + !! but no key_netcdf4 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: nfid + INTEGER, INTENT(in) :: nvid + INTEGER, INTENT(in) :: ishuffle + INTEGER, INTENT(in) :: ideflate + INTEGER, INTENT(in) :: ideflate_level + !! + INTEGER :: iret + !! + iret = NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) + SET_NF90_DEF_VAR_DEFLATE = iret + END FUNCTION SET_NF90_DEF_VAR_DEFLATE + + SUBROUTINE GET_NF90_SYMBOL(sym_name, ivalue) + CHARACTER(len=*), INTENT(in) :: sym_name + INTEGER, INTENT(out) :: ivalue + SELECT CASE (sym_name) + CASE ("NF90_HDF5") + ivalue = NF90_HDF5 + CASE DEFAULT + WRITE(*,*) "Warning: unknown case in GET_NF90_SYMBOL" + END SELECT + END SUBROUTINE GET_NF90_SYMBOL +#endif + +!------------------ +END MODULE nc4interface diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/e3/e39fdc4d5091bc2a62948bbcd0e3636983c4d41f.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/e3/e39fdc4d5091bc2a62948bbcd0e3636983c4d41f.svn-base new file mode 100644 index 0000000..bdc4095 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/e3/e39fdc4d5091bc2a62948bbcd0e3636983c4d41f.svn-base @@ -0,0 +1,2501 @@ +MODULE histcom +!- +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!- + USE netcdf + USE nc4interface ! needed to allow compilation with netcdf3 libraries +!- + USE stringop, ONLY : nocomma,cmpblank,findpos,find_str,strlowercase + USE mathelp, ONLY : mathop,moycum,buildop + USE fliocom, ONLY : flio_dom_file,flio_dom_att + USE calendar + USE errioipsl, ONLY : ipslerr,ipsldbg +!- + IMPLICIT NONE +!- + PRIVATE + PUBLIC :: histbeg,histdef,histhori,histvert,histend, & + & histwrite,histclo,histsync,ioconf_modname +!--------------------------------------------------------------------- +!- Some confusing vocabulary in this code ! +!- ========================================= +!- +!- A REGULAR grid is a grid which is i,j indexes +!- and thus it is stored in a 2D matrix. +!- This is opposed to a IRREGULAR grid which is only in a vector +!- and where we do not know which neighbors we have. +!- As a consequence we need the bounds for each grid-cell. +!- +!- A RECTILINEAR grid is a special case of a regular grid +!- in which all longitudes for i constant are equal +!- and all latitudes for j constant. +!- In other words we do not need the full 2D matrix +!- to describe the grid, just two vectors. +!--------------------------------------------------------------------- +!- + INTERFACE histbeg + MODULE PROCEDURE histb_reg1d,histb_reg2d,histb_irreg + END INTERFACE +!- + INTERFACE histhori + MODULE PROCEDURE histh_reg1d,histh_reg2d,histh_irreg + END INTERFACE +!- + INTERFACE histwrite +!--------------------------------------------------------------------- +!- The "histwrite" routines will give the data to the I/O system. +!- It will trigger the operations to be performed, +!- and the writting to the file if needed +!- +!- We test for the work to be done at this time here so that at a +!- later stage we can call different operation and write subroutine +!- for the REAL and INTEGER interfaces +!- +!- INPUT +!- idf : The ID of the file on which this variable is to be, +!- written. The variable should have been defined in +!- this file before. +!- pvarname : The short name of the variable +!- pitau : Current timestep +!- pdata : The variable, I mean the real data ! +!- nbindex : The number of indexes provided. If it is equal to +!- the size of the full field as provided in histdef +!- then nothing is done. +!- nindex : The indices used to expand the variable (pdata) +!- onto the full field. +!--------------------------------------------------------------------- +!- histwrite - we have to prepare different type of fields : +!- real and integer, 1,2 or 3D + MODULE PROCEDURE histwrite_r1d,histwrite_r2d,histwrite_r3d + END INTERFACE +!- +! Fixed parameter +!- + INTEGER,PARAMETER :: nb_files_max=20,nb_var_max=400, & + & nb_hax_max=5,nb_zax_max=10,nbopp_max=10 + REAL,PARAMETER :: missing_val=nf90_fill_real + INTEGER,PARAMETER,PUBLIC :: & + & hist_r4=nf90_real4, hist_r8=nf90_real8 +!- +! Variable derived type +!- +TYPE T_D_V + INTEGER :: ncvid + INTEGER :: nbopp + CHARACTER(LEN=20) :: v_name,unit_name + CHARACTER(LEN=256) :: title,std_name + CHARACTER(LEN=80) :: fullop + CHARACTER(LEN=7) :: topp + CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp + REAL,DIMENSION(nbopp_max) :: scal +!-External type (for R4/R8) + INTEGER :: v_typ +!-Sizes of the associated grid and zommed area + INTEGER,DIMENSION(3) :: scsize,zorig,zsize +!-Sizes for the data as it goes through the various math operations + INTEGER,DIMENSION(3) :: datasz_in = -1 + INTEGER :: datasz_max = -1 +!- + INTEGER :: h_axid,z_axid,t_axid +!- + REAL,DIMENSION(2) :: hist_minmax + LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE. +!-Book keeping of the axes + INTEGER :: tdimid,tbndid=-1,tax_last + LOGICAL :: l_bnd + CHARACTER(LEN=40) :: tax_name +!- + REAL :: freq_opp,freq_wrt + INTEGER :: & + & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt +!- For future optimization + REAL,POINTER,DIMENSION(:) :: t_bf +!# REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D +!# REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D +!# REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D +END TYPE T_D_V +!- +! File derived type +!- +TYPE :: T_D_F +!-NETCDF IDs for file + INTEGER :: ncfid=-1 +!-Time variables + INTEGER :: itau0=0 + REAL :: date0,deltat +!-Counter of elements (variables, time-horizontal-vertical axis + INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0 +!-NETCDF dimension IDs for time-[time_bounds]-longitude-latitude + INTEGER :: tid,bid,xid,yid +!-General definitions in the NETCDF file + INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_siz +!-The horizontal axes + CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name +!-The vertical axes + INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids + CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name +!- + LOGICAL :: regular=.TRUE. +!-DOMAIN ID + INTEGER :: dom_id_svg=-1 +!- + TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V +END TYPE T_D_F +!- +TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F +!- +! A list of functions which require special action +! (Needs to be updated when functions are added +! but they are well located here) +!- + CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill' +!- Some configurable variables with locks + CHARACTER(LEN=80),SAVE :: model_name='An IPSL model' + LOGICAL,SAVE :: lock_modname=.FALSE. +!- +!=== +CONTAINS +!=== +!- +SUBROUTINE histb_reg1d & + & (pfilename,pim,plon,pjm,plat, & + & par_orix,par_szx,par_oriy,par_szy, & + & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- histbeg for 1D regular horizontal coordinates (see histb_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: pfilename + INTEGER,INTENT(IN) :: pim,pjm + REAL,DIMENSION(pim),INTENT(IN) :: plon + REAL,DIMENSION(pjm),INTENT(IN) :: plat + INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!--------------------------------------------------------------------- + CALL histb_all & + & (1,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_1d=plon,y_1d=plat, & + & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & + & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) +!------------------------- +END SUBROUTINE histb_reg1d +!=== +SUBROUTINE histb_reg2d & + & (pfilename,pim,plon,pjm,plat, & + & par_orix,par_szx,par_oriy,par_szy, & + & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- histbeg for 2D regular horizontal coordinates (see histb_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: pfilename + INTEGER,INTENT(IN) :: pim,pjm + REAL,DIMENSION(pim,pjm),INTENT(IN) :: plon,plat + INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!--------------------------------------------------------------------- + CALL histb_all & + & (2,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_2d=plon,y_2d=plat, & + & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & + & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) +!------------------------- +END SUBROUTINE histb_reg2d +!=== +SUBROUTINE histb_irreg & + & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & + & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- histbeg for irregular horizontal coordinates (see histb_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: pfilename + INTEGER,INTENT(IN) :: pim + REAL,DIMENSION(pim),INTENT(IN) :: plon,plat + REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!--------------------------------------------------------------------- + CALL histb_all & + & (3,pfilename,pim,pim,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds, & + & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) +!------------------------- +END SUBROUTINE histb_irreg +!=== +SUBROUTINE histb_all & + & (k_typ,nc_name,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_1d,y_1d,x_2d,y_2d,k_orx,k_szx,k_ory,k_szy, & + & x_bnds,y_bnds,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- General interface for horizontal grids. +!- This subroutine initializes a netcdf file and returns the ID. +!- It will set up the geographical space on which the data will be +!- stored and offers the possibility of seting a zoom. +!- In the case of irregular grids, all the data comes in as vectors +!- and for the grid we have the coordinates of the 4 corners. +!- It also gets the global parameters into the I/O subsystem. +!- +!- INPUT +!- +!- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) +!- nc_name : Name of the netcdf file to be created +!- pim : Size of arrays in longitude direction +!- pjm : Size of arrays in latitude direction (pjm=pim for type 3) +!- +!- pitau0 : time step at which the history tape starts +!- pdate0 : The Julian date at which the itau was equal to 0 +!- pdeltat : Time step, in seconds, of the counter itau +!- used in histwrite for instance +!- +!- OUTPUT +!- +!- phoriid : Identifier of the horizontal grid +!- idf : Identifier of the file +!- +!- Optional INPUT arguments +!- +!- For rectilinear or irregular grid +!- x_1d : The longitudes +!- y_1d : The latitudes +!- For regular grid +!- x_2d : The longitudes +!- y_2d : The latitudes +!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. +!- +!- For regular grid (reg1d or reg2d), +!- the next 4 arguments allow to define a horizontal zoom +!- for this file. It is assumed that all variables to come +!- have the same index space. This can not be assumed for +!- the z axis and thus we define the zoom in histdef. +!- k_orx : Origin of the slab of data within the X axis (pim) +!- k_szx : Size of the slab of data in X +!- k_ory : Origin of the slab of data within the Y axis (pjm) +!- k_szy : Size of the slab of data in Y +!- +!- For irregular grid. +!- x_bnds : The boundaries of the grid in longitude +!- y_bnds : The boundaries of the grid in latitude +!- +!- For all grids. +!- +!- domain_id : Domain identifier +!- +!- mode : String of (case insensitive) blank-separated words +!- defining the mode used to create the file. +!- Supported keywords : 32, 64 +!- "32/64" defines the offset mode. +!- The default offset mode is 64 bits. +!- Keywords "NETCDF4" and "CLASSIC" are reserved +!- for future use. +!- +!- snc4chunks : Structure containing chunk partitioning parameters +!- for 4-D variables and a logical switch to toggle +!- between netcdf3 o/p (false) and netcdf4 chunked +!- and compressed o/p (true) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: k_typ + CHARACTER(LEN=*),INTENT(IN) :: nc_name + INTEGER,INTENT(IN) :: pim,pjm + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d + INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!- + INTEGER :: nfid,iret,m_c + CHARACTER(LEN=120) :: file + CHARACTER(LEN=30) :: timenow + CHARACTER(LEN=11) :: c_nam + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (k_typ == 1) THEN + c_nam = 'histb_reg1d' + ELSEIF (k_typ == 2) THEN + c_nam = 'histb_reg2d' + ELSEIF (k_typ == 3) THEN + c_nam = 'histb_irreg' + ELSE + CALL ipslerr (3,"histbeg", & + & 'Illegal value of k_typ argument','in internal interface','?') + ENDIF +!- + IF (l_dbg) WRITE(*,*) c_nam//" 0.0" +!- +! Search for a free index +!- + idf = -1 + DO nfid=1,nb_files_max + IF (W_F(nfid)%ncfid < 0) THEN + idf = nfid; EXIT; + ENDIF + ENDDO + IF (idf < 0) THEN + CALL ipslerr (3,"histbeg", & + & 'Table of files too small. You should increase nb_files_max', & + & 'in histcom.f90 in order to accomodate all these files',' ') + ENDIF +!- +! 1.0 Transfering into the common for future use +!- + IF (l_dbg) WRITE(*,*) c_nam//" 1.0" +!- + W_F(idf)%itau0 = pitau0 + W_F(idf)%date0 = pdate0 + W_F(idf)%deltat = pdeltat +!- +! 2.0 Initializes all variables for this file +!- + IF (l_dbg) WRITE(*,*) c_nam//" 2.0" +!- + W_F(idf)%n_var = 0 + W_F(idf)%n_tax = 0 + W_F(idf)%n_hax = 0 + W_F(idf)%n_zax = 0 +!- + IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN + W_F(idf)%slab_ori(1:2) = (/ k_orx,k_ory /) + W_F(idf)%slab_siz(1:2) = (/ k_szx,k_szy /) + ELSE + W_F(idf)%slab_ori(1:2) = (/ 1,1 /) + W_F(idf)%slab_siz(1:2) = (/ pim,1 /) + ENDIF +!- +! 3.0 Opening netcdf file and defining dimensions +!- + IF (l_dbg) WRITE(*,*) c_nam//" 3.0" +!- +! Add DOMAIN number and ".nc" suffix in file name if needed +!- + file = nc_name + CALL flio_dom_file (file,domain_id) +!- +! Check the mode +!? See fliocom for HDF4 ???????????????????????????????????????????????? +!- + IF (PRESENT(mode)) THEN + SELECT CASE (TRIM(mode)) + CASE('32') + m_c = NF90_CLOBBER + CASE('64') + m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) + CASE DEFAULT + CALL ipslerr (3,"histbeg", & + & 'Invalid argument mode for file :',TRIM(file), & + & 'Supported values are 32 or 64') + END SELECT + ELSE + m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) + ENDIF +!- + IF (PRESENT(snc4chunks)) THEN + IF (snc4chunks%luse) CALL get_nf90_symbol("NF90_HDF5", m_c) + ENDIF +!- +! Create file +!- + iret = NF90_CREATE(file,m_c,nfid) +!- + IF (k_typ == 1) THEN + iret = NF90_DEF_DIM(nfid,'lon',k_szx,W_F(idf)%xid) + iret = NF90_DEF_DIM(nfid,'lat',k_szy,W_F(idf)%yid) + ELSEIF (k_typ == 2) THEN + iret = NF90_DEF_DIM(nfid,'x',k_szx,W_F(idf)%xid) + iret = NF90_DEF_DIM(nfid,'y',k_szy,W_F(idf)%yid) + ELSEIF (k_typ == 3) THEN + iret = NF90_DEF_DIM(nfid,'x',pim,W_F(idf)%xid) + W_F(idf)%yid = W_F(idf)%xid + ENDIF +!- +! 4.0 Declaring the geographical coordinates and other attributes +!- + IF (l_dbg) WRITE(*,*) c_nam//" 4.0" +!- + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'Conventions','CF-1.1') + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'file_name',TRIM(file)) + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'production',TRIM(model_name)) + lock_modname = .TRUE. + CALL ioget_timestamp (timenow) + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) +!- +! 5.0 Saving some important information on this file in the common +!- + IF (l_dbg) WRITE(*,*) c_nam//" 5.0" +!- + IF (PRESENT(domain_id)) THEN + W_F(idf)%dom_id_svg = domain_id + ENDIF + W_F(idf)%ncfid = nfid + IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN + W_F(idf)%full_size(1:2) = (/ pim,pjm /) + W_F(idf)%regular=.TRUE. + ELSEIF (k_typ == 3) THEN + W_F(idf)%full_size(1:2) = (/ pim,1 /) + W_F(idf)%regular=.FALSE. + ENDIF +!- +! 6.0 storing the geographical coordinates +!- + IF (k_typ == 1) THEN + CALL histh_all & + & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & + & x_1d=x_1d,y_1d=y_1d) + ELSEIF (k_typ == 2) THEN + CALL histh_all & + & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & + & x_2d=x_2d,y_2d=y_2d) + ELSEIF (k_typ == 3) THEN + CALL histh_all & + & (k_typ,idf,pim,pim,' ','Default grid',phoriid, & + & x_1d=x_1d,y_1d=y_1d,x_bnds=x_bnds,y_bnds=y_bnds) + ENDIF +!----------------------- +END SUBROUTINE histb_all +!=== +SUBROUTINE histh_reg1d & + & (idf,pim,plon,pjm,plat,phname,phtitle,phid) +!--------------------------------------------------------------------- +!- histhori for 1d regular grid (see histh_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pim,pjm + REAL,INTENT(IN),DIMENSION(:) :: plon,plat + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid +!--------------------------------------------------------------------- + CALL histh_all & + & (1,idf,pim,pjm,phname,phtitle,phid,x_1d=plon,y_1d=plat) +!------------------------- +END SUBROUTINE histh_reg1d +!=== +SUBROUTINE histh_reg2d & + & (idf,pim,plon,pjm,plat,phname,phtitle,phid) +!--------------------------------------------------------------------- +!- histhori for 2d regular grid (see histh_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pim,pjm + REAL,INTENT(IN),DIMENSION(:,:) :: plon,plat + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid +!--------------------------------------------------------------------- + CALL histh_all & + & (2,idf,pim,pjm,phname,phtitle,phid,x_2d=plon,y_2d=plat) +!------------------------- +END SUBROUTINE histh_reg2d +!=== +SUBROUTINE histh_irreg & + & (idf,pim,plon,plon_bounds,plat,plat_bounds,phname,phtitle,phid) +!--------------------------------------------------------------------- +!- histhori for irregular grid (see histh_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pim + REAL,DIMENSION(:),INTENT(IN) :: plon,plat + REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid +!--------------------------------------------------------------------- + CALL histh_all & + & (3,idf,pim,pim,phname,phtitle,phid, & + & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds) +!------------------------- +END SUBROUTINE histh_irreg +!=== +SUBROUTINE histh_all & + & (k_typ,idf,pim,pjm,phname,phtitle,phid, & + & x_1d,y_1d,x_2d,y_2d,x_bnds,y_bnds) +!--------------------------------------------------------------------- +!- General interface for horizontal grids. +!- This subroutine is made to declare a new horizontal grid. +!- It has to have the same number of points as +!- the original and thus in this routine we will only +!- add two variable (longitude and latitude). +!- Any variable in the file can thus point to this pair +!- through an attribute. This routine is very usefull +!- to allow staggered grids. +!- +!- INPUT +!- +!- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) +!- idf : The id of the file to which the grid should be added +!- pim : Size in the longitude direction +!- pjm : Size in the latitude direction (pjm=pim for type 3) +!- phname : The name of grid +!- phtitle : The title of the grid +!- +!- OUTPUT +!- +!- phid : Id of the created grid +!- +!- Optional INPUT arguments +!- +!- For rectilinear or irregular grid +!- x_1d : The longitudes +!- y_1d : The latitudes +!- For regular grid +!- x_2d : The longitudes +!- y_2d : The latitudes +!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. +!- +!- For irregular grid. +!- x_bnds : The boundaries of the grid in longitude +!- y_bnds : The boundaries of the grid in latitude +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: k_typ + INTEGER,INTENT(IN) :: idf,pim,pjm + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid + REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds +!- + CHARACTER(LEN=25) :: lon_name,lat_name + CHARACTER(LEN=30) :: lonbound_name,latbound_name + INTEGER :: i_s,i_e + INTEGER,DIMENSION(2) :: dims,dims_b + INTEGER :: nbbounds + INTEGER :: nlonidb,nlatidb,twoid + LOGICAL :: transp = .FALSE. + REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans + REAL :: wmn,wmx + INTEGER :: nlonid,nlatid + INTEGER :: o_x,o_y,s_x,s_y + INTEGER :: iret,nfid + CHARACTER(LEN=11) :: c_nam + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (k_typ == 1) THEN + c_nam = 'histh_reg1d' + ELSEIF (k_typ == 2) THEN + c_nam = 'histh_reg2d' + ELSEIF (k_typ == 3) THEN + c_nam = 'histh_irreg' + ELSE + CALL ipslerr (3,"histhori", & + & 'Illegal value of k_typ argument','in internal interface','?') + ENDIF +!- +! 1.0 Check that all fits in the buffers +!- + IF ( (pim /= W_F(idf)%full_size(1)) & + & .OR.(W_F(idf)%regular.AND.(pjm /= W_F(idf)%full_size(2))) & + & .OR.(.NOT.W_F(idf)%regular.AND.(W_F(idf)%full_size(2) /= 1)) ) THEN + CALL ipslerr (3,"histhori", & + & 'The new horizontal grid does not have the same size', & + & 'as the one provided to histbeg. This is not yet ', & + & 'possible in the hist package.') + ENDIF +!- +! 1.1 Create all the variables needed +!- + IF (l_dbg) WRITE(*,*) c_nam//" 1.0" +!- + nfid = W_F(idf)%ncfid +!- + IF (k_typ == 3) THEN + IF (SIZE(x_bnds,DIM=1) == pim) THEN + nbbounds = SIZE(x_bnds,DIM=2) + transp = .TRUE. + ELSEIF (SIZE(x_bnds,DIM=2) == pim) THEN + nbbounds = SIZE(x_bnds,DIM=1) + transp = .FALSE. + ELSE + CALL ipslerr (3,"histhori", & + & 'The boundary variable does not have any axis corresponding', & + & 'to the size of the longitude or latitude variable','.') + ENDIF + ALLOCATE(bounds_trans(nbbounds,pim)) + iret = NF90_DEF_DIM(nfid,'nbnd',nbbounds,twoid) + dims_b(1:2) = (/ twoid,W_F(idf)%xid /) + ENDIF +!- + dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) +!- + IF (k_typ == 1) THEN + IF (W_F(idf)%n_hax == 0) THEN + lon_name = 'lon' + lat_name = 'lat' + ELSE + lon_name = 'lon_'//TRIM(phname) + lat_name = 'lat_'//TRIM(phname) + ENDIF + ELSEIF (k_typ == 2) THEN + IF (W_F(idf)%n_hax == 0) THEN + lon_name = 'nav_lon' + lat_name = 'nav_lat' + ELSE + lon_name = 'nav_lon_'//TRIM(phname) + lat_name = 'nav_lat_'//TRIM(phname) + ENDIF + ELSEIF (k_typ == 3) THEN + IF (W_F(idf)%n_hax == 0) THEN + lon_name = 'nav_lon' + lat_name = 'nav_lat' + ELSE + lon_name = 'nav_lon_'//TRIM(phname) + lat_name = 'nav_lat_'//TRIM(phname) + ENDIF + lonbound_name = TRIM(lon_name)//'_bounds' + latbound_name = TRIM(lat_name)//'_bounds' + ENDIF +!- +! 1.2 Save the informations +!- + phid = W_F(idf)%n_hax+1 + W_F(idf)%n_hax = phid + W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /) +!- +! 2.0 Longitude +!- + IF (l_dbg) WRITE(*,*) c_nam//" 2.0" +!- + i_s = 1; + IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN + i_e = 1; wmn = MINVAL(x_1d); wmx = MAXVAL(x_1d); + ELSEIF (k_typ == 2) THEN + i_e = 2; wmn = MINVAL(x_2d); wmx = MAXVAL(x_2d); + ENDIF + iret = NF90_DEF_VAR(nfid,lon_name,NF90_REAL4,dims(i_s:i_e),nlonid) + IF (k_typ == 1) THEN + iret = NF90_PUT_ATT(nfid,nlonid,'axis',"X") + ENDIF + iret = NF90_PUT_ATT(nfid,nlonid,'standard_name',"longitude") + iret = NF90_PUT_ATT(nfid,nlonid,'units',"degrees_east") + iret = NF90_PUT_ATT(nfid,nlonid,'valid_min',REAL(wmn,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlonid,'valid_max',REAL(wmx,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlonid,'long_name',"Longitude") + iret = NF90_PUT_ATT(nfid,nlonid,'nav_model',TRIM(phtitle)) +!- + IF (k_typ == 3) THEN +!--- +!-- 2.1 Longitude bounds +!--- + iret = NF90_PUT_ATT(nfid,nlonid,'bounds',TRIM(lonbound_name)) + iret = NF90_DEF_VAR(nfid,lonbound_name,NF90_REAL4,dims_b(1:2),nlonidb) + iret = NF90_PUT_ATT(nfid,nlonidb,'long_name', & + & 'Boundaries for coordinate variable '//TRIM(lon_name)) + ENDIF +!- +! 3.0 Latitude +!- + IF (l_dbg) WRITE(*,*) c_nam//" 3.0" +!- + i_e = 2; + IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN + i_s = 2; wmn = MINVAL(y_1d); wmx = MAXVAL(y_1d); + ELSEIF (k_typ == 2) THEN + i_s = 1; wmn = MINVAL(y_2d); wmx = MAXVAL(y_2d); + ENDIF + iret = NF90_DEF_VAR(nfid,lat_name,NF90_REAL4,dims(i_s:i_e),nlatid) + IF (k_typ == 1) THEN + iret = NF90_PUT_ATT(nfid,nlatid,'axis',"Y") + ENDIF +!- + iret = NF90_PUT_ATT(nfid,nlatid,'standard_name',"latitude") + iret = NF90_PUT_ATT(nfid,nlatid,'units',"degrees_north") + iret = NF90_PUT_ATT(nfid,nlatid,'valid_min',REAL(wmn,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlatid,'valid_max',REAL(wmx,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlatid,'long_name',"Latitude") + iret = NF90_PUT_ATT(nfid,nlatid,'nav_model',TRIM(phtitle)) +!- + IF (k_typ == 3) THEN +!--- +!-- 3.1 Latitude bounds +!--- + iret = NF90_PUT_ATT(nfid,nlatid,'bounds',TRIM(latbound_name)) + iret = NF90_DEF_VAR(nfid,latbound_name,NF90_REAL4,dims_b(1:2),nlatidb) + iret = NF90_PUT_ATT(nfid,nlatidb,'long_name', & + & 'Boundaries for coordinate variable '//TRIM(lat_name)) + ENDIF +!- + iret = NF90_ENDDEF(nfid) +!- +! 4.0 storing the geographical coordinates +!- + IF (l_dbg) WRITE(*,*) c_nam//" 4.0" +!- + IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN + o_x = W_F(idf)%slab_ori(1) + o_y = W_F(idf)%slab_ori(2) + s_x = W_F(idf)%slab_siz(1) + s_y = W_F(idf)%slab_siz(2) +!--- +!-- Transfer the longitude and the latitude +!--- + IF (k_typ == 1) THEN + iret = NF90_PUT_VAR(nfid,nlonid,x_1d(o_x:o_x+s_x-1)) + iret = NF90_PUT_VAR(nfid,nlatid,y_1d(o_y:o_y+s_y-1)) + ELSEIF (k_typ == 2) THEN + iret = NF90_PUT_VAR(nfid,nlonid, & + & x_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) + iret = NF90_PUT_VAR(nfid,nlatid, & + & y_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) + ENDIF + ELSEIF (k_typ == 3) THEN +!--- +!-- Transfer the longitude and the longitude bounds +!--- + iret = NF90_PUT_VAR(nfid,nlonid,x_1d(1:pim)) +!--- + IF (transp) THEN + bounds_trans = TRANSPOSE(x_bnds) + ELSE + bounds_trans = x_bnds + ENDIF + iret = NF90_PUT_VAR(nfid,nlonidb,bounds_trans(1:nbbounds,1:pim)) +!--- +!-- Transfer the latitude and the latitude bounds +!--- + iret = NF90_PUT_VAR(nfid,nlatid,y_1d(1:pim)) +!--- + IF (transp) THEN + bounds_trans = TRANSPOSE(y_bnds) + ELSE + bounds_trans = y_bnds + ENDIF + iret = NF90_PUT_VAR(nfid,nlatidb,bounds_trans(1:nbbounds,1:pim)) +!--- + DEALLOCATE(bounds_trans) + ENDIF +!- + iret = NF90_REDEF(nfid) +!----------------------- +END SUBROUTINE histh_all +!=== +SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, & + & pzsize,pzvalues,pzaxid,pdirect) +!--------------------------------------------------------------------- +!- This subroutine defines a vertical axis and returns it s id. +!- It gives the user the possibility to the user to define many +!- different vertical axes. For each variable defined with histdef a +!- vertical axis can be specified with by it s ID. +!- +!- INPUT +!- +!- idf : ID of the file the variable should be archived in +!- pzaxname : Name of the vertical axis +!- pzaxtitle: title of the vertical axis +!- pzaxunit : Units of the vertical axis (no units if blank string) +!- pzsize : size of the vertical axis +!- pzvalues : Coordinate values of the vetical axis +!- +!- pdirect : is an optional argument which allows to specify the +!- the positive direction of the axis : up or down. +!- OUTPUT +!- +!- pzaxid : Returns the ID of the axis. +!- Note that this is not the netCDF ID ! +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pzsize + CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle + REAL,INTENT(IN) :: pzvalues(pzsize) + INTEGER,INTENT(OUT) :: pzaxid + CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: pdirect +!- + INTEGER :: pos,iv,zdimid,zaxid_tmp + CHARACTER(LEN=70) :: str71 + CHARACTER(LEN=20) :: direction + INTEGER :: iret,leng,nfid + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Verifications : +! Do we have enough space for an extra axis ? +! Is the name already in use ? +!- + IF (l_dbg) WRITE(*,*) "histvert : 1.0 Verifications", & + & pzaxname,'---',pzaxunit,'---',pzaxtitle +!- +! Direction of the vertical axis. Can we get if from the user. +!- + IF (PRESENT(pdirect)) THEN + direction = TRIM(pdirect) + CALL strlowercase (direction) + ELSE + direction = 'unknown' + ENDIF +!- +! Check the consistency of the attribute +!- + IF ( PRESENT(pdirect) & + & .AND.(direction /= 'up') & + & .AND.(direction /= 'down') ) THEN + direction = 'unknown' + CALL ipslerr (2,"histvert",& + & "The specified positive direction for the vertical axis is invalid.",& + & "The value must be up or down.","The attribute will not be written.") + ENDIF +!- + IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN + CALL ipslerr (3,"histvert", & + & 'Table of vertical axes too small. You should increase ',& + & 'nb_zax_max in histcom.f90 in order to accomodate all ', & + & 'these variables ') + ENDIF +!- + iv = W_F(idf)%n_zax + IF (iv > 1) THEN + CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos) + ELSE + pos = 0 + ENDIF +!- + IF (pos > 0) THEN + WRITE(str71,'("Check variable ",A," in file",I3)') & + & TRIM(pzaxname),idf + CALL ipslerr (3,"histvert", & + & "Vertical axis already exists",TRIM(str71), & + & "Can also be a wrong file ID in another declaration") + ENDIF +!- + iv = W_F(idf)%n_zax+1 +!- +! 2.0 Add the information to the file +!- + IF (l_dbg) & + & WRITE(*,*) "histvert : 2.0 Add the information to the file" +!- + nfid = W_F(idf)%ncfid +!- + leng = MIN(LEN_TRIM(pzaxname),20) + iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp) + iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_REAL4, & + & zaxid_tmp,zdimid) + iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z") + iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number") + leng = MIN(LEN_TRIM(pzaxunit),20) + IF (leng > 0) THEN + iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng)) + ENDIF + IF (direction /= 'unknown') THEN + iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction)) + ENDIF + iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', & + & REAL(MINVAL(pzvalues(1:pzsize)),KIND=4)) + iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', & + & REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4)) + leng = MIN(LEN_TRIM(pzaxname),20) + iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng)) + leng = MIN(LEN_TRIM(pzaxtitle),80) + iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng)) +!- + iret = NF90_ENDDEF (nfid) +!- + iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize)) +!- + iret = NF90_REDEF (nfid) +!- +!- 3.0 add the information to the common +!- + IF (l_dbg) & + & WRITE(*,*) "histvert : 3.0 add the information to the common" +!- + W_F(idf)%n_zax = iv + W_F(idf)%zax_size(iv) = pzsize + W_F(idf)%zax_name(iv) = pzaxname + W_F(idf)%zax_ids(iv) = zaxid_tmp + pzaxid = iv +!---------------------- +END SUBROUTINE histvert +!=== +SUBROUTINE histdef & + & (idf,pvarname,ptitle,punit, & + & pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, & + & xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name) +!--------------------------------------------------------------------- +!- With this subroutine each variable to be archived on the history +!- tape should be declared. +!- +!- It gives the user the choise of operation +!- to be performed on the variables, the frequency of this operation +!- and finaly the frequency of the archiving. +!- +!- INPUT +!- +!- idf : ID of the file the variable should be archived in +!- pvarname : Name of the variable, short and easy to remember +!- ptitle : Full name of the variable +!- punit : Units of the variable (no units if blank string) +!- +!- The next 3 arguments give the size of that data +!- that will be passed to histwrite. The zoom will be +!- done there with the horizontal information obtained +!- in histbeg and the vertical information to follow. +!- +!- pxsize : Size in X direction (size of the data that will be +!- given to histwrite) +!- pysize : Size in Y direction +!- phoriid : ID of the horizontal axis +!- +!- The next two arguments give the vertical zoom to use. +!- +!- pzsize : Size in Z direction (If 1 then no axis is declared +!- for this variable and pzid is not used) +!- par_oriz : Off set of the zoom +!- par_szz : Size of the zoom +!- +!- pzid : ID of the vertical axis to use. It has to have +!- the size of the zoom. +!- xtype : External netCDF type (hist_r4/hist_r8) +!- popp : Operation to be performed. The following options +!- exist today : +!- inst : keeps instantaneous values for writting +!- ave : Computes the average from call between writes +!- pfreq_opp: Frequency of this operation (in seconds) +!- pfreq_wrt: Frequency at which the variable should be +!- written (in seconds) +!- var_range: Range of the variable. +!- If the minimum is greater than the maximum, +!- the values will be calculated. +!- +!- VERSION +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid + INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid + CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle + REAL,INTENT(IN) :: pfreq_opp,pfreq_wrt + REAL,DIMENSION(2),OPTIONAL,INTENT(IN) :: var_range + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name +!- + INTEGER :: iv + CHARACTER(LEN=70) :: str70,str71,str72 + CHARACTER(LEN=20) :: tmp_name + CHARACTER(LEN=40) :: str40 + CHARACTER(LEN=10) :: str10 + CHARACTER(LEN=120) :: ex_topps + REAL :: un_an,un_jour,test_fopp,test_fwrt + INTEGER :: pos,buff_sz + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' +!- + W_F(idf)%n_var = W_F(idf)%n_var+1 + iv = W_F(idf)%n_var +!- + IF (iv > nb_var_max) THEN + CALL ipslerr (3,"histdef", & + & 'Table of variables too small. You should increase nb_var_max',& + & 'in histcom.f90 in order to accomodate all these variables', & + & ' ') + ENDIF +!- +! 1.0 Transfer informations on the variable to the common +! and verify that it does not already exist +!- + IF (l_dbg) WRITE(*,*) "histdef : 1.0" +!- + IF (iv > 1) THEN + CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos) + ELSE + pos = 0 + ENDIF +!- + IF (pos > 0) THEN + str70 = "Variable already exists" + WRITE(str71,'("Check variable ",a," in file",I3)') & + & TRIM(pvarname),idf + str72 = "Can also be a wrong file ID in another declaration" + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- + W_F(idf)%W_V(iv)%v_name = pvarname + W_F(idf)%W_V(iv)%title = ptitle + W_F(idf)%W_V(iv)%unit_name = punit + IF (PRESENT(standard_name)) THEN + W_F(idf)%W_V(iv)%std_name = standard_name + ELSE + W_F(idf)%W_V(iv)%std_name = ptitle + ENDIF + tmp_name = W_F(idf)%W_V(iv)%v_name +!- +! 1.1 decode the operations +!- + W_F(idf)%W_V(iv)%fullop = popp + CALL buildop & + & (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, & + & W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, & + & W_F(idf)%W_V(iv)%nbopp) +!- +! 1.2 If we have an even number of operations +! then we need to add identity +!- + IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN + W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1 + W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident' + W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val + ENDIF +!- +! 1.3 External type of the variable +!- + IF (xtype == hist_r8) THEN + W_F(idf)%W_V(iv)%v_typ = hist_r8 + ELSE + W_F(idf)%W_V(iv)%v_typ = hist_r4 + ENDIF +!- +! 2.0 Put the size of the variable in the common and check +!- + IF (l_dbg) THEN + WRITE(*,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, & + & W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), & + & W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp) + ENDIF +!- + W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /) + W_F(idf)%W_V(iv)%zorig(1:3) = & + & (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /) + W_F(idf)%W_V(iv)%zsize(1:3) = & + & (/ W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2),par_szz /) +!- +! Is the size of the full array the same as that of the coordinates ? +!- + IF ( (pxsize > W_F(idf)%full_size(1)) & + & .OR.(pysize > W_F(idf)%full_size(2)) ) THEN +!- + str70 = "The size of the variable is different "// & + & "from the one of the coordinates" + WRITE(str71,'("Size of coordinates :",2I4)') & + & W_F(idf)%full_size(1),W_F(idf)%full_size(2) + WRITE(str72,'("Size declared for variable ",a," :",2I4)') & + & TRIM(tmp_name),pxsize,pysize + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +! Is the size of the zoom smaller than the coordinates ? +!- + IF ( (W_F(idf)%full_size(1) < W_F(idf)%slab_siz(1)) & + & .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_siz(2)) ) THEN + str70 = & + & "Size of variable should be greater or equal to those of the zoom" + WRITE(str71,'("Size of XY zoom :",2I4)') & + & W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2) + WRITE(str72,'("Size declared for variable ",A," :",2I4)') & + & TRIM(tmp_name),pxsize,pysize + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +! 2.1 We store the horizontal grid information with minimal +! and a fall back onto the default grid +!- + IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN + W_F(idf)%W_V(iv)%h_axid = phoriid + ELSE + W_F(idf)%W_V(iv)%h_axid = 1 + CALL ipslerr (2,"histdef", & + & 'We use the default grid for variable as an invalide',& + & 'ID was provided for variable : ',TRIM(pvarname)) + ENDIF +!- +! 2.2 Check the vertical coordinates if needed +!- + IF (par_szz > 1) THEN +!- +!-- Does the vertical coordinate exist ? +!- + IF (pzid > W_F(idf)%n_zax) THEN + WRITE(str70, & + & '("The vertical coordinate chosen for variable ",A)') & + & TRIM(tmp_name) + str71 = " Does not exist." + CALL ipslerr (3,"histdef",str70,str71," ") + ENDIF +!- +!-- Is the vertical size of the variable equal to that of the axis ? +!- + IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN + str70 = "The size of the zoom does not correspond "// & + & "to the size of the chosen vertical axis" + WRITE(str71,'("Size of zoom in z :",I4)') par_szz + WRITE(str72,'("Size declared for axis ",A," :",I4)') & + & TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid) + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +!-- Is the zoom smaller that the total size of the variable ? +!- + IF (pzsize < par_szz) THEN + str70 = "The vertical size of variable "// & + & "is smaller than that of the zoom." + WRITE(str71,'("Declared vertical size of data :",I5)') pzsize + WRITE(str72,'("Size of zoom for variable ",a," = ",I5)') & + & TRIM(tmp_name),par_szz + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF + W_F(idf)%W_V(iv)%z_axid = pzid + ELSE + W_F(idf)%W_V(iv)%z_axid = -99 + ENDIF +!- +! 3.0 We get the size of the arrays histwrite will get +! and eventually allocate the time_buffer +!- + IF (l_dbg) THEN + WRITE(*,*) "histdef : 3.0" + ENDIF +!- + buff_sz = W_F(idf)%W_V(iv)%zsize(1) & + & *W_F(idf)%W_V(iv)%zsize(2) & + & *W_F(idf)%W_V(iv)%zsize(3) +!- + IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN + ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz)) + W_F(idf)%W_V(iv)%t_bf(:) = 0. + IF (l_dbg) THEN + WRITE(*,*) "histdef : 3.0 allocating time_buffer for", & + & " idf = ",idf," iv = ",iv," size = ",buff_sz + ENDIF + ENDIF +!- +! 4.0 Transfer the frequency of the operations and check +! for validity. We have to pay attention to negative values +! of the frequency which indicate monthly time-steps. +! The strategy is to bring it back to seconds for the tests +!- + IF (l_dbg) WRITE(*,*) "histdef : 4.0" +!- + W_F(idf)%W_V(iv)%freq_opp = pfreq_opp + W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt +!- + CALL ioget_calendar(un_an,un_jour) + IF (pfreq_opp < 0) THEN + CALL ioget_calendar(un_an) + test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour + ELSE + test_fopp = pfreq_opp + ENDIF + IF (pfreq_wrt < 0) THEN + CALL ioget_calendar(un_an) + test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour + ELSE + test_fwrt = pfreq_wrt + ENDIF +!- +! 4.1 Frequency of operations and output should be larger than deltat ! +!- + IF (test_fopp < W_F(idf)%deltat) THEN + str70 = 'Frequency of operations should be larger than deltat' + WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & + & TRIM(tmp_name),pfreq_opp + str72 = "PATCH : frequency set to deltat" +!- + CALL ipslerr (2,"histdef",str70,str71,str72) +!- + W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat + ENDIF +!- + IF (test_fwrt < W_F(idf)%deltat) THEN + str70 = 'Frequency of output should be larger than deltat' + WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & + & TRIM(tmp_name),pfreq_wrt + str72 = "PATCH : frequency set to deltat" +!- + CALL ipslerr (2,"histdef",str70,str71,str72) +!- + W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat + ENDIF +!- +! 4.2 First the existence of the operation is tested and then +! its compaticility with the choice of frequencies +!- + IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN + IF (test_fopp /= test_fwrt) THEN + str70 = 'For instantaneous output the frequency '// & + & 'of operations and output' + WRITE(str71, & + & '("should be the same, this was not case for variable ",a)') & + & TRIM(tmp_name) + str72 = "PATCH : The smalest frequency of both is used" + CALL ipslerr (2,"histdef",str70,str71,str72) + IF (test_fopp < test_fwrt) THEN + W_F(idf)%W_V(iv)%freq_opp = pfreq_opp + W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp + ELSE + W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt + W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt + ENDIF + ENDIF + ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN + IF (test_fopp > test_fwrt) THEN + str70 = 'For averages the frequency of operations '// & + & 'should be smaller or equal' + WRITE(str71, & + & '("to that of output. It is not the case for variable ",a)') & + & TRIM(tmp_name) + str72 = 'PATCH : The output frequency is used for both' + CALL ipslerr (2,"histdef",str70,str71,str72) + W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt + ENDIF + ELSE + WRITE (str70,'("Operation on variable ",A," is unknown")') & + & TRIM(tmp_name) + WRITE (str71,'("operation requested is :",A)') & + & W_F(idf)%W_V(iv)%topp + WRITE (str72,'("File ID :",I3)') idf + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +! 5.0 Initialize other variables of the common +!- + IF (l_dbg) WRITE(*,*) "histdef : 5.0" +!- + W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range)) + IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN + W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2)) + IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN + W_F(idf)%W_V(iv)%hist_minmax(1:2) = & + & (/ ABS(missing_val),-ABS(missing_val) /) + ELSE + W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2) + ENDIF + ENDIF +!- +! - freq_opp(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0 +! - freq_wrt(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0 +! - freq_opp(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0 +! - freq_wrt(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0 + W_F(idf)%W_V(iv)%nb_opp = 0 + W_F(idf)%W_V(iv)%nb_wrt = 0 +!- +! 6.0 Get the time axis for this variable +!- + IF (l_dbg) WRITE(*,*) "histdef : 6.0" +!- +! No time axis for once, l_max, l_min or never operation +!- + IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once') & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN + IF (TRIM(W_F(idf)%W_V(iv)%topp) == 'inst') THEN + str10 = 't_inst_' + ELSE + str10 = 't_op_' + ENDIF + IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN + WRITE (UNIT=str40,FMT='(A,I8.8)') & +& TRIM(str10),INT(W_F(idf)%W_V(iv)%freq_wrt) + ELSE + WRITE (UNIT=str40,FMT='(A,I2.2,"month")') & +& TRIM(str10),ABS(INT(W_F(idf)%W_V(iv)%freq_wrt)) + ENDIF + CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos) + IF (pos < 0) THEN + W_F(idf)%n_tax = W_F(idf)%n_tax+1 + W_F(idf)%W_V(iv)%l_bnd = & + & (TRIM(W_F(idf)%W_V(iv)%topp) /= 'inst') + W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40 + W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0 + W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax + ELSE + W_F(idf)%W_V(iv)%t_axid = pos + ENDIF + ELSE + IF (l_dbg) THEN + WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----' + ENDIF + W_F(idf)%W_V(iv)%t_axid = -99 + ENDIF +!- +! 7.0 prepare frequence of writing and operation +! for never or once operation +!- + IF ( (TRIM(W_F(idf)%W_V(iv)%topp) == 'once') & + & .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN + W_F(idf)%W_V(iv)%freq_opp = 0. + W_F(idf)%W_V(iv)%freq_wrt = 0. + ENDIF +!--------------------- +END SUBROUTINE histdef +!=== +SUBROUTINE histend (idf, snc4chunks) +!--------------------------------------------------------------------- +!- This subroutine end the decalaration of variables and sets the +!- time axes in the netcdf file and puts it into the write mode. +!- +!- INPUT +!- +!- idf : ID of the file to be worked on +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!- + INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt + INTEGER,DIMENSION(4) :: dims + INTEGER :: year,month,day,hours,minutes + REAL :: sec + REAL :: rtime0 + CHARACTER(LEN=30) :: str30 + CHARACTER(LEN=35) :: str35 + CHARACTER(LEN=120) :: assoc + CHARACTER(LEN=70) :: str70 + CHARACTER(LEN=3),DIMENSION(12) :: cal = & + & (/ 'JAN','FEB','MAR','APR','MAY','JUN', & + & 'JUL','AUG','SEP','OCT','NOV','DEC' /) + CHARACTER(LEN=7) :: tmp_opp + LOGICAL :: l_b + LOGICAL :: l_dbg + INTEGER, DIMENSION(4) :: ichunksz ! NETCDF4 chunk sizes + INTEGER :: ichunkalg, ishuffle,& + ideflate, ideflate_level + LOGICAL :: lchunk = .FALSE. ! logical switch to activate chunking when appropriate +!- + ! NetCDF4 chunking and compression parameters + ichunkalg = 0 + ishuffle = 1 + ideflate = 1 + ideflate_level = 1 + ! +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + nfid = W_F(idf)%ncfid +!- +! 1.0 Create the time axes +!- + IF (l_dbg) WRITE(*,*) "histend : 1.0" +!- +! 1.1 Define the time dimensions needed for this file +!- + iret = NF90_DEF_DIM (nfid,'time_counter', & + & NF90_UNLIMITED,W_F(idf)%tid) + DO iv=1,W_F(idf)%n_var + IF (W_F(idf)%W_V(iv)%l_bnd) THEN + iret = NF90_DEF_DIM (nfid,'tbnds',2,W_F(idf)%bid) + EXIT + ENDIF + ENDDO +!- +! 1.2 Define all the time axes needed for this file +!- + DO itx=1,W_F(idf)%n_tax + dims(1) = W_F(idf)%tid + l_b = (INDEX(W_F(idf)%W_V(itx)%tax_name,"t_op_") == 1) + IF (itx > 1) THEN + str30 = W_F(idf)%W_V(itx)%tax_name + ELSE + str30 = "time_counter" + ENDIF + IF (l_b) THEN + str35 = TRIM(str30)//'_bnds' + ENDIF + iret = NF90_DEF_VAR (nfid,TRIM(str30),NF90_REAL8, & + & dims(1),W_F(idf)%W_V(itx)%tdimid) + IF (itx <= 1) THEN + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T") + ENDIF + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'standard_name',"time") +!--- +! To transform the current itau into a real date and take it +! as the origin of the file requires the time counter to change. +! Thus it is an operation the user has to ask for. +! This function should thus only be re-instated +! if there is a ioconf routine to control it. +!--- +!-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf)) + rtime0 = W_F(idf)%date0 +!- + CALL ju2ymds(rtime0,year,month,day,sec) +!--- +! Catch any error induced by a change in calendar ! +!--- + IF (year < 0) THEN + year = 2000+year + ENDIF +!- + hours = INT(sec/(60.*60.)) + minutes = INT((sec-hours*60.*60.)/60.) + sec = sec-(hours*60.*60.+minutes*60.) +!- + WRITE (UNIT=str70, & + & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & + & 'seconds since ',year,month,day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'units',TRIM(str70)) +!- + CALL ioget_calendar (str30) + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'calendar',TRIM(str30)) +!- + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'title','Time') +!- + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'long_name','Time axis') +!- + WRITE (UNIT=str70, & + & FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & + & year,cal(month),day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'time_origin',TRIM(str70)) +!--- + IF (l_b) THEN + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'bounds',TRIM(str35)) + dims(1:2) = (/ W_F(idf)%bid,W_F(idf)%tid /) + iret = NF90_DEF_VAR (nfid,TRIM(str35),NF90_REAL8, & + & dims(1:2),W_F(idf)%W_V(itx)%tbndid) + ENDIF + ENDDO +!- +! 2.0 declare the variables +!- + IF (l_dbg) WRITE(*,*) "histend : 2.0" +!- + DO iv=1,W_F(idf)%n_var +!--- + itax = W_F(idf)%W_V(iv)%t_axid +!--- + IF (W_F(idf)%regular) THEN + dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) + dim_cnt = 2 + ELSE + dims(1) = W_F(idf)%xid + dim_cnt = 1 + ENDIF +!--- + tmp_opp = W_F(idf)%W_V(iv)%topp + ziv = W_F(idf)%W_V(iv)%z_axid +!--- +! 2.1 dimension of field +!--- + IF ((TRIM(tmp_opp) /= 'never')) THEN + IF ( (TRIM(tmp_opp) /= 'once') & + & .AND.(TRIM(tmp_opp) /= 'l_max') & + & .AND.(TRIM(tmp_opp) /= 'l_min') ) THEN + IF (ziv == -99) THEN + ndim = dim_cnt+1 + dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /) + ELSE + ndim = dim_cnt+2 + dims(dim_cnt+1:dim_cnt+2) = & + & (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /) + ENDIF + ELSE + IF (ziv == -99) THEN + ndim = dim_cnt + dims(dim_cnt+1:dim_cnt+2) = (/ 0,0 /) + ELSE + ndim = dim_cnt+1 + dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /) + ENDIF + ENDIF +!- + iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), & + & W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid) +!- + IF( ndim == 4 ) THEN + IF( PRESENT( snc4chunks ) ) THEN + IF( snc4chunks%luse ) THEN + ichunksz = 1 + iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%xid, len = ichunksz(1) ) + iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%yid, len = ichunksz(2) ) + IF ( ziv .NE. -99 ) & + iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%zax_ids(ziv), len = ichunksz(3) ) + ichunksz(1) = MIN(ichunksz(1), MAX((ichunksz(1)-1)/snc4chunks%ni + 1,16)) + ichunksz(2) = MIN(ichunksz(2), MAX((ichunksz(2)-1)/snc4chunks%nj + 1,16)) + ichunksz(3) = MIN(ichunksz(3), MAX((ichunksz(3)-1)/snc4chunks%nk + 1, 1)) + ! Always use a chunk size of 1 for the unlimited dimension + iret = SET_NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) + iret = SET_NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) + ENDIF + ENDIF + ENDIF + W_F(idf)%W_V(iv)%ncvid = nvid +!- + IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN + iret = NF90_PUT_ATT (nfid,nvid,'units', & + & TRIM(W_F(idf)%W_V(iv)%unit_name)) + ENDIF + iret = NF90_PUT_ATT (nfid,nvid,'standard_name', & + & TRIM(W_F(idf)%W_V(iv)%std_name)) +!- + IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN + iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL8) + ELSE + iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL4) + ENDIF + IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN + IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN + iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=8)) + iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=8)) + ELSE + iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4)) + iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4)) + ENDIF + ENDIF + iret = NF90_PUT_ATT (nfid,nvid,'long_name', & + & TRIM(W_F(idf)%W_V(iv)%title)) + iret = NF90_PUT_ATT (nfid,nvid,'online_operation', & + & TRIM(W_F(idf)%W_V(iv)%fullop)) +!- + SELECT CASE(ndim) + CASE(-3,2:4) + CASE DEFAULT + CALL ipslerr (3,"histend", & + & 'less than 2 or more than 4 dimensions are not', & + & 'allowed at this stage',' ') + END SELECT +!- + assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) & + & //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1)) +!- + ziv = W_F(idf)%W_V(iv)%z_axid + IF (ziv > 0) THEN + str30 = W_F(idf)%zax_name(ziv) + assoc = TRIM(str30)//' '//TRIM(assoc) + ENDIF +!- + IF (itax > 0) THEN + IF (itax > 1) THEN + str30 = W_F(idf)%W_V(itax)%tax_name + ELSE + str30 = "time_counter" + ENDIF + assoc = TRIM(str30)//' '//TRIM(assoc) +!- + IF (l_dbg) THEN + WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", & + & W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt + ENDIF +!- + iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', & + & REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4)) + iret = NF90_PUT_ATT (nfid,nvid,'interval_write', & + & REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4)) + ENDIF + iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc)) + ENDIF + ENDDO +!- +! 2.2 Add DOMAIN attributes if needed +!- + IF (W_F(idf)%dom_id_svg >= 0) THEN + CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg) + ENDIF +!- +! 3.0 Put the netcdf file into write mode +!- + IF (l_dbg) WRITE(*,*) "histend : 3.0" +!- + iret = NF90_ENDDEF (nfid) +!- +! 4.0 Give some informations to the user +!- + IF (l_dbg) WRITE(*,*) "histend : 4.0" +!- +!!$ WRITE(str70,'("All variables have been initialized on file :",I3)') idf +!!$ CALL ipslerr (1,'histend',str70,'',' ') +!--------------------- +END SUBROUTINE histend +!=== +SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + REAL,DIMENSION(:),INTENT(IN) :: pdata + CHARACTER(LEN=*),INTENT(IN) :: pvarname +!--------------------------------------------------------------------- + CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata) +!--------------------------- +END SUBROUTINE histwrite_r1d +!=== +SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + REAL,DIMENSION(:,:),INTENT(IN) :: pdata + CHARACTER(LEN=*),INTENT(IN) :: pvarname +!--------------------------------------------------------------------- + CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata) +!--------------------------- +END SUBROUTINE histwrite_r2d +!=== +SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata + CHARACTER(LEN=*),INTENT(IN) :: pvarname +!--------------------------------------------------------------------- + CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata) +!--------------------------- +END SUBROUTINE histwrite_r3d +!=== +SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, & + & pdata_1d,pdata_2d,pdata_3d) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + CHARACTER(LEN=*),INTENT(IN) :: pvarname + REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: pdata_1d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: pdata_2d + REAL,DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: pdata_3d +!- + LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d + INTEGER :: iv,io,nbpt_out + INTEGER :: nbpt_in1 + INTEGER,DIMENSION(2) :: nbpt_in2 + INTEGER,DIMENSION(3) :: nbpt_in3 + REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1 + CHARACTER(LEN=7) :: tmp_opp + CHARACTER(LEN=13) :: c_nam + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + l1d=PRESENT(pdata_1d); l2d=PRESENT(pdata_2d); l3d=PRESENT(pdata_3d); + IF (l1d) THEN + c_nam = 'histwrite_r1d' + ELSE IF (l2d) THEN + c_nam = 'histwrite_r2d' + ELSE IF (l3d) THEN + c_nam = 'histwrite_r3d' + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite : ",c_nam + ENDIF +!- +! 1.0 Try to catch errors like specifying the wrong file ID. +! Thanks Marine for showing us what errors users can make ! +!- + IF ( (idf < 1).OR.(idf > nb_files_max) ) THEN + CALL ipslerr (3,"histwrite", & + & 'Illegal file ID in the histwrite of variable',pvarname,' ') + ENDIF +!- +! 1.1 Find the id of the variable to be written and the real time +!- + CALL histvar_seq (idf,pvarname,iv) +!- +! 2.0 do nothing for never operation +!- + tmp_opp = W_F(idf)%W_V(iv)%topp +!- + IF (TRIM(tmp_opp) == "never") THEN + W_F(idf)%W_V(iv)%last_opp_chk = -99 + W_F(idf)%W_V(iv)%last_wrt_chk = -99 + ENDIF +!- +! 3.0 We check if we need to do an operation +!- + IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN + CALL ipslerr (3,"histwrite", & + & 'This variable has already been analysed at the present', & + & 'time step',TRIM(pvarname)) + ENDIF +!- + CALL isittime & + & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & + & W_F(idf)%W_V(iv)%freq_opp, & + & W_F(idf)%W_V(iv)%last_opp, & + & W_F(idf)%W_V(iv)%last_opp_chk,do_oper) +!- +! 4.0 We check if we need to write the data +!- + IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN + CALL ipslerr (3,"histwrite", & + & 'This variable as already been written for the present', & + & 'time step',' ') + ENDIF +!- + CALL isittime & + & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & + & W_F(idf)%W_V(iv)%freq_wrt, & + & W_F(idf)%W_V(iv)%last_wrt, & + & W_F(idf)%W_V(iv)%last_wrt_chk,do_write) +!- +! 5.0 histwrite called +!- + IF (do_oper.OR.do_write) THEN +!- +!-- 5.1 Get the sizes of the data we will handle +!- + IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN +!---- There is the risk here that the user has over-sized the array. +!---- But how can we catch this ? +!---- In the worst case we will do impossible operations +!---- on part of the data ! + W_F(idf)%W_V(iv)%datasz_in(1:3) = -1 + IF (l1d) THEN + W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d) + ELSE IF (l2d) THEN + W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1) + W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2) + ELSE IF (l3d) THEN + W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1) + W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2) + W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3) + ENDIF + ENDIF +!- +!-- 5.2 The maximum size of the data will give the size of the buffer +!- + IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN + largebuf = .FALSE. + DO io=1,W_F(idf)%W_V(iv)%nbopp + IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN + largebuf = .TRUE. + ENDIF + ENDDO + IF (largebuf) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%scsize(1) & + & *W_F(idf)%W_V(iv)%scsize(2) & + & *W_F(idf)%W_V(iv)%scsize(3) + ELSE + IF (l1d) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%datasz_in(1) + ELSE IF (l2d) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%datasz_in(1) & + & *W_F(idf)%W_V(iv)%datasz_in(2) + ELSE IF (l3d) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%datasz_in(1) & + & *W_F(idf)%W_V(iv)%datasz_in(2) & + & *W_F(idf)%W_V(iv)%datasz_in(3) + ENDIF + ENDIF + ENDIF +!- + IF (.NOT.ALLOCATED(tbf_1)) THEN + IF (l_dbg) THEN + WRITE(*,*) & + & c_nam//" : allocate tbf_1 for size = ", & + & W_F(idf)%W_V(iv)%datasz_max + ENDIF + ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) + ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN + IF (l_dbg) THEN + WRITE(*,*) & + & c_nam//" : re-allocate tbf_1 for size = ", & + & W_F(idf)%W_V(iv)%datasz_max + ENDIF + DEALLOCATE(tbf_1) + ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) + ENDIF +!- +!-- We have to do the first operation anyway. +!-- Thus we do it here and change the ranke +!-- of the data at the same time. This should speed up things. +!- + nbpt_out = W_F(idf)%W_V(iv)%datasz_max + IF (l1d) THEN + nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1) + CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, & + & missing_val,nbindex,nindex, & + & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) + ELSE IF (l2d) THEN + nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2) + CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, & + & missing_val,nbindex,nindex, & + & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) + ELSE IF (l3d) THEN + nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3) + CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, & + & missing_val,nbindex,nindex, & + & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) + ENDIF + CALL histwrite_real (idf,iv,pitau,nbpt_out, & + & tbf_1,nbindex,nindex,do_oper,do_write) + ENDIF +!- +! 6.0 Manage time steps +!- + IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN + W_F(idf)%W_V(iv)%last_opp_chk = pitau + W_F(idf)%W_V(iv)%last_wrt_chk = pitau + ELSE + W_F(idf)%W_V(iv)%last_opp_chk = -99 + W_F(idf)%W_V(iv)%last_wrt_chk = -99 + ENDIF +!----------------------- +END SUBROUTINE histw_rnd +!=== +SUBROUTINE histwrite_real & + & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write) +!--------------------------------------------------------------------- +!- This subroutine is internal and does the calculations and writing +!- if needed. At a later stage it should be split into an operation +!- and writing subroutines. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,iv, & + & nbindex,nindex(nbindex),nbdpt + REAL,DIMENSION(:) :: tbf_1 + LOGICAL,INTENT(IN) :: do_oper,do_write +!- + INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout + INTEGER :: nx,ny,nz,ky,kz,kt,kc + INTEGER,DIMENSION(4) :: corner,edges + INTEGER :: itime +!- + REAL :: rtime + REAL,DIMENSION(2) :: t_bnd + CHARACTER(LEN=7) :: tmp_opp + REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name + WRITE(*,*) "histwrite 0.0 : nbindex :",nbindex + WRITE(*,*) "histwrite 0.0 : nindex :",nindex(1:MIN(3,nbindex)),'...' + ENDIF +!- +! The sizes which can be encoutered +!- + tsz = W_F(idf)%W_V(iv)%zsize(1) & + & *W_F(idf)%W_V(iv)%zsize(2) & + & *W_F(idf)%W_V(iv)%zsize(3) +!- +! 1.0 We allocate and the temporary space needed for operations. +! The buffers are only deallocated when more space is needed. +! This reduces the umber of allocates but increases memory needs. +!- + IF (.NOT.ALLOCATED(tbf_2)) THEN + IF (l_dbg) THEN + WRITE(*,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1) + ENDIF + ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) + ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN + IF (l_dbg) THEN + WRITE(*,*) "histwrite_real 1.2 re-allocate tbf_2 : ", & + & SIZE(tbf_1)," instead of ",SIZE(tbf_2) + ENDIF + DEALLOCATE(tbf_2) + ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) + ENDIF +!- + rtime = pitau*W_F(idf)%deltat + tmp_opp = W_F(idf)%W_V(iv)%topp +!- +! 3.0 Do the operations or transfer the slab of data into tbf_1 +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 3.0",idf + ENDIF +!- +! 3.1 DO the Operations only if needed +!- + IF (do_oper) THEN + nbout = nbdpt +!- +!-- 3.4 We continue the sequence of operations +!-- we started in the interface routine +!- + DO io=2,W_F(idf)%W_V(iv)%nbopp,2 + nbin = nbout + nbout = W_F(idf)%W_V(iv)%datasz_max + CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, & + & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), & + & nbout,tbf_2) + IF (l_dbg) THEN + WRITE(*,*) & + & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io) + ENDIF +!- + nbin = nbout + nbout = W_F(idf)%W_V(iv)%datasz_max + CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, & + & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), & + & nbout,tbf_1) + IF (l_dbg) THEN + WRITE(*,*) & + & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1) + ENDIF + ENDDO +!- +! 3.5 Zoom into the data +!- + IF (l_dbg) THEN + WRITE(*,*) & + & "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1) + WRITE(*,*) & + & "histwrite: 3.5 slab in X :", & + & W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1) + WRITE(*,*) & + & "histwrite: 3.5 slab in Y :", & + & W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2) + WRITE(*,*) & + & "histwrite: 3.5 slab in Z :", & + & W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3) + WRITE(*,*) & + & "histwrite: 3.5 slab of input:", & + & W_F(idf)%W_V(iv)%scsize(1), & + & W_F(idf)%W_V(iv)%scsize(2), & + & W_F(idf)%W_V(iv)%scsize(3) + ENDIF +!--- +!-- We have to consider blocks of contiguous data +!--- + nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1) + ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1) + nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1) + IF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & + & .AND.( W_F(idf)%W_V(iv)%zsize(1) & + & == W_F(idf)%W_V(iv)%scsize(1)) & + & .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) & + & .AND.( W_F(idf)%W_V(iv)%zsize(2) & + & == W_F(idf)%W_V(iv)%scsize(2))) THEN + kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny + tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz) + ELSEIF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & + & .AND.( W_F(idf)%W_V(iv)%zsize(1) & + & == W_F(idf)%W_V(iv)%scsize(1))) THEN + kc = -nx*ny + DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 + kc = kc+nx*ny + kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) & + & +W_F(idf)%W_V(iv)%zorig(2)-1)*nx + tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny) + ENDDO + ELSE + kc = -nx + DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 + DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1 + kc = kc+nx + kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) & + & *W_F(idf)%W_V(iv)%scsize(1) & + & +W_F(idf)%W_V(iv)%zorig(1)-1 + tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx) + ENDDO + ENDDO + ENDIF +!- +!-- 4.0 Get the min and max of the field +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 4.0 tbf_1",idf,iv, & + & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex + ENDIF +!- + IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN + W_F(idf)%W_V(iv)%hist_minmax(1) = & + & MIN(W_F(idf)%W_V(iv)%hist_minmax(1), & + & MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) + W_F(idf)%W_V(iv)%hist_minmax(2) = & + & MAX(W_F(idf)%W_V(iv)%hist_minmax(2), & + & MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) + ENDIF +!- +!-- 5.0 Do the operations if needed. In the case of instantaneous +!-- output we do not transfer to the time_buffer. +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz + ENDIF +!- + IF ( (TRIM(tmp_opp) /= "inst") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN + CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, & + & tbf_2,W_F(idf)%W_V(iv)%nb_opp) + ENDIF +!- + W_F(idf)%W_V(iv)%last_opp = pitau + W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1 +!- + ENDIF +!- +! 6.0 Write to file if needed +!- + IF (l_dbg) WRITE(*,*) "histwrite: 6.0",idf +!- + IF (do_write) THEN +!- + nfid = W_F(idf)%ncfid + nvid = W_F(idf)%W_V(iv)%ncvid +!- +!-- 6.1 Do the operations that are needed before writting +!- + IF (l_dbg) WRITE(*,*) "histwrite: 6.1",idf +!- + IF ( (TRIM(tmp_opp) /= "inst") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN + t_bnd(1:2) = (/ W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat,rtime /) + rtime = (t_bnd(1)+t_bnd(2))/2.0 + ENDIF +!- +!-- 6.2 Add a value to the time axis of this variable if needed +!- + IF ( (TRIM(tmp_opp) /= "l_max") & + & .AND.(TRIM(tmp_opp) /= "l_min") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN +!- + IF (l_dbg) WRITE(*,*) "histwrite: 6.2",idf +!- + itax = W_F(idf)%W_V(iv)%t_axid + itime = W_F(idf)%W_V(iv)%nb_wrt+1 +!- + IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN + iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, & + & (/ rtime /),start=(/ itime /),count=(/ 1 /)) + IF (W_F(idf)%W_V(itax)%tbndid > 0) THEN + iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tbndid, & + & t_bnd,start=(/ 1,itime /),count=(/ 2,1 /)) + ENDIF + W_F(idf)%W_V(itax)%tax_last = itime + ENDIF + ELSE + itime=1 + ENDIF +!- +!-- 6.3 Write the data. Only in the case of instantaneous output +! we do not write the buffer. +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime + ENDIF +!- + IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN + IF (W_F(idf)%regular) THEN + corner(1:4) = (/ 1,1,itime,0 /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & + & W_F(idf)%W_V(iv)%zsize(2),1,0 /) + ELSE + corner(1:4) = (/ 1,itime,0,0 /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /) + ENDIF + ELSE + IF (W_F(idf)%regular) THEN + corner(1:4) = (/ 1,1,1,itime /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & + & W_F(idf)%W_V(iv)%zsize(2), & + & W_F(idf)%W_V(iv)%zsize(3),1 /) + ELSE + corner(1:4) = (/ 1,1,itime,0 /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & + & W_F(idf)%W_V(iv)%zsize(3),1,0 /) + ENDIF + ENDIF +!- + IF ( (TRIM(tmp_opp) /= "inst") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN + iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, & + & start=corner(1:4),count=edges(1:4)) + ELSE + iret = NF90_PUT_VAR (nfid,nvid,tbf_2, & + & start=corner(1:4),count=edges(1:4)) + ENDIF +!- + W_F(idf)%W_V(iv)%last_wrt = pitau + W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1 + W_F(idf)%W_V(iv)%nb_opp = 0 +!--- +! After the write the file can be synchronized so that no data is +! lost in case of a crash. This feature gives up on the benefits of +! buffering and should only be used in debuging mode. A flag is +! needed here to switch to this mode. +!--- +! iret = NF90_SYNC (nfid) +!- + ENDIF +!---------------------------- +END SUBROUTINE histwrite_real +!=== +SUBROUTINE histvar_seq (idf,pvarname,idv) +!--------------------------------------------------------------------- +!- This subroutine optimize the search for the variable in the table. +!- In a first phase it will learn the succession of the variables +!- called and then it will use the table to guess what comes next. +!- It is the best solution to avoid lengthy searches through array +!- vectors. +!- +!- ARGUMENTS : +!- +!- idf : id of the file on which we work +!- pvarname : The name of the variable we are looking for +!- idv : The var id we found +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: idf + CHARACTER(LEN=*),INTENT(IN) :: pvarname + INTEGER,INTENT(out) :: idv +!- + LOGICAL,SAVE :: learning(nb_files_max)=.TRUE. + INTEGER,SAVE :: overlap(nb_files_max) = -1 + INTEGER,SAVE :: varseq(nb_files_max,nb_var_max*3) + INTEGER,SAVE :: varseq_len(nb_files_max) = 0 + INTEGER,SAVE :: varseq_pos(nb_files_max) + INTEGER,SAVE :: varseq_err(nb_files_max) = 0 + INTEGER :: ib,sp,nn,pos + CHARACTER(LEN=70) :: str70 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) 'histvar_seq, start of the subroutine :',learning(idf) + ENDIF +!- + IF (learning(idf)) THEN +!- +!-- 1.0 We compute the length over which we are going +!-- to check the overlap +!- + IF (overlap(idf) <= 0) THEN + IF (W_F(idf)%n_var > 6) THEN + overlap(idf) = W_F(idf)%n_var/3*2 + ELSE + overlap(idf) = W_F(idf)%n_var + ENDIF + ENDIF +!- +!-- 1.1 Find the position of this string +!- + CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) + IF (pos > 0) THEN + idv = pos + ELSE + CALL ipslerr (3,"histvar_seq", & + & 'The name of the variable you gave has not been declared', & + & 'You should use subroutine histdef for declaring variable', & + & TRIM(pvarname)) + ENDIF +!- +!-- 1.2 If we have not given up we store the position +!-- in the sequence of calls +!- + IF (varseq_err(idf) >= 0) THEN + sp = varseq_len(idf)+1 + IF (sp <= nb_var_max*3) THEN + varseq(idf,sp) = idv + varseq_len(idf) = sp + ELSE + CALL ipslerr (2,"histvar_seq",& + & 'The learning process has failed and we give up. '// & + & 'Either you sequence is',& + & 'too complex or I am too dumb. '// & + & 'This will only affect the efficiency',& + & 'of your code. Thus if you wish to save time'// & + & ' contact the IOIPSL team. ') + WRITE(*,*) 'The sequence we have found up to now :' + WRITE(*,*) varseq(idf,1:sp-1) + varseq_err(idf) = -1 + ENDIF +!- +!---- 1.3 Check if we have found the right overlap +!- + IF (varseq_len(idf) >= overlap(idf)*2) THEN +!- +!------ We skip a few variables if needed as they could come +!------ from the initialisation of the model. +!- + DO ib = 0,sp-overlap(idf)*2 + IF ( learning(idf) .AND.& + & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -& + & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN + learning(idf) = .FALSE. + varseq_len(idf) = sp-overlap(idf)-ib + varseq_pos(idf) = overlap(idf)+ib + varseq(idf,1:varseq_len(idf)) = & + & varseq(idf,ib+1:ib+varseq_len(idf)) + ENDIF + ENDDO + ENDIF + ENDIF + ELSE +!- +!-- 2.0 Now we know how the calls to histwrite are sequenced +!-- and we can get a guess at the var ID +!- + nn = varseq_pos(idf)+1 + IF (nn > varseq_len(idf)) nn = 1 +!- + idv = varseq(idf,nn) +!- + IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN + CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) + IF (pos > 0) THEN + idv = pos + ELSE + CALL ipslerr (3,"histvar_seq", & + & 'The name of the variable you gave has not been declared',& + & 'You should use subroutine histdef for declaring variable', & + & TRIM(pvarname)) + ENDIF + varseq_err(idf) = varseq_err(idf)+1 + ELSE +!- +!---- We only keep the new position if we have found the variable +!---- this way. This way an out of sequence call to histwrite does +!---- not defeat the process. +!- + varseq_pos(idf) = nn + ENDIF +!- +!!$ IF (varseq_err(idf) >= 10) THEN +!!$ WRITE(str70,'("for file ",I3)') idf +!!$ CALL ipslerr (2,"histvar_seq", & +!!$ & 'There were 10 errors in the learned sequence of variables',& +!!$ & str70,'This looks like a bug, please report it.') +!!$ varseq_err(idf) = 0 +!!$ ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) & + & 'histvar_seq, end of the subroutine :',TRIM(pvarname),idv + ENDIF +!------------------------- +END SUBROUTINE histvar_seq +!=== +SUBROUTINE histsync (idf) +!--------------------------------------------------------------------- +!- This subroutine will synchronise all +!- (or one if defined) opened files. +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! idf : optional argument for fileid + INTEGER,INTENT(in),OPTIONAL :: idf +!- + INTEGER :: ifile,iret,i_s,i_e +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->histsync" + ENDIF +!- + IF (PRESENT(idf)) THEN + IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN + IF (W_F(idf)%ncfid > 0) THEN + i_s = idf + i_e = idf + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'histsync', & + & 'Unable to synchronise the file :','probably','not opened') + ENDIF + ELSE + CALL ipslerr (3,'histsync','Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_files_max + ENDIF +!- + DO ifile=i_s,i_e + IF (W_F(ifile)%ncfid > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' histsync - synchronising file number ',ifile + ENDIF + iret = NF90_SYNC(W_F(ifile)%ncfid) + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-histsync" + ENDIF +!---------------------- +END SUBROUTINE histsync +!=== +SUBROUTINE histclo (idf) +!--------------------------------------------------------------------- +!- This subroutine will close all (or one if defined) opened files +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! idf : optional argument for fileid + INTEGER,INTENT(in),OPTIONAL :: idf +!- + INTEGER :: ifile,nfid,nvid,iret,iv,i_s,i_e + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->histclo" + ENDIF +!- + IF (PRESENT(idf)) THEN + IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN + IF (W_F(idf)%ncfid > 0) THEN + i_s = idf + i_e = idf + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'histclo', & + & 'Unable to close the file :','probably','not opened') + ENDIF + ELSE + CALL ipslerr (3,'histclo','Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_files_max + ENDIF +!- + DO ifile=i_s,i_e + IF (W_F(ifile)%ncfid > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' histclo - closing specified file number :',ifile + ENDIF + nfid = W_F(ifile)%ncfid + iret = NF90_REDEF(nfid) +!----- +!---- 1. Loop on the number of variables to add some final information +!----- + IF (l_dbg) THEN + WRITE(*,*) ' Entering loop on vars : ',W_F(ifile)%n_var + ENDIF + DO iv=1,W_F(ifile)%n_var +!------ Extrema + IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN + IF (l_dbg) THEN + WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, & + & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1) + WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, & + & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2) + ENDIF + IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN +!---------- Put the min and max values on the file + nvid = W_F(ifile)%W_V(iv)%ncvid + IF (W_F(ifile)%W_V(iv)%v_typ == hist_r8) THEN + iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=8)) + iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=8)) + ELSE + iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4)) + iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4)) + ENDIF + ENDIF + ENDIF +!------ Time-Buffers + IF (ASSOCIATED(W_F(ifile)%W_V(iv)%t_bf)) THEN + DEALLOCATE(W_F(ifile)%W_V(iv)%t_bf) + ENDIF +!------ Reinitialize the sizes + W_F(ifile)%W_V(iv)%datasz_in(:) = -1 + W_F(ifile)%W_V(iv)%datasz_max = -1 + ENDDO +!----- +!---- 2. Close the file +!----- + IF (l_dbg) WRITE(*,*) ' close file :',nfid + iret = NF90_CLOSE(nfid) + W_F(ifile)%ncfid = -1 + W_F(ifile)%dom_id_svg = -1 + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-histclo" + ENDIF +!--------------------- +END SUBROUTINE histclo +!=== +SUBROUTINE ioconf_modname (str) +!--------------------------------------------------------------------- +!- This subroutine allows to configure the name +!- of the model written into the file +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: str +!--------------------------------------------------------------------- + IF (.NOT.lock_modname) THEN + model_name = str(1:MIN(LEN_TRIM(str),80)) + lock_modname = .TRUE. + ELSE + CALL ipslerr (2,"ioconf_modname", & + & 'The model name can only be changed once and only', & + & 'before it is used. It is now set to :',model_name) + ENDIF +!---------------------------- +END SUBROUTINE ioconf_modname +!- +!=== +!- +!----------------- +END MODULE histcom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/fc/fc25afd211441c4f0faa09648d4edf5f2c58bc3a.svn-base b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/fc/fc25afd211441c4f0faa09648d4edf5f2c58bc3a.svn-base new file mode 100644 index 0000000..9961094 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/pristine/fc/fc25afd211441c4f0faa09648d4edf5f2c58bc3a.svn-base @@ -0,0 +1,328 @@ +PROGRAM ncregular +! +!$Id$ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- This code replaces a 2D surface grid by vectors. +!- Obviously it only works if you have a regular grid. +!- +!- Jan Polcher (polcher@lmd.jussieu.fr) +!- Jacques Bellier (jacques.bellier@cea.fr) +!--------------------------------------------------------------------- + USE netcdf +!- + IMPLICIT NONE +!- + INTEGER :: iread, if, in, iv, sz + INTEGER :: ier, nb_files, iret, ndims, nvars, nb_glat + INTEGER :: lon_dim_id, lat_dim_id + INTEGER :: lon_len, lat_len, lon_id, lat_id + INTEGER :: nav_lon_id, nav_lat_id + INTEGER :: alloc_stat_lon, alloc_stat_lat +!- + INTEGER,ALLOCATABLE :: file_id(:), tax_id(:) + CHARACTER(LEN=80),ALLOCATABLE :: names(:) + CHARACTER(LEN=80) :: dim_name + CHARACTER(LEN=80) :: varname + CHARACTER(LEN=20) :: xname, yname, lonname, latname + LOGICAL :: check, regular +!- + REAL,ALLOCATABLE :: lon(:), lat(:), lon2(:), lat2(:) + REAL,ALLOCATABLE :: del_lon(:), del_lat(:) +!- + INTEGER iargc, getarg + EXTERNAL iargc, getarg +!--------------------------------------------------------------------- + alloc_stat_lon = 0 + alloc_stat_lat = 0 +!- + iread = iargc() +!- + ALLOCATE (names(iread),stat=ier) + IF (ier /= 0) THEN + WRITE (*,*) ' Could not allocate names of size ', iread + STOP 'nctax' + ENDIF +!- + CALL nct_getarg (iread, nb_files, names, check, & + & xname, yname, lonname, latname) +!- +! Allocate space +!- + ALLOCATE (file_id(nb_files),stat=ier) + IF (ier /= 0) THEN + WRITE (*,*) ' Could not allocate file_id of size ', nb_files + STOP 'nctax' + ENDIF +!- + ALLOCATE (tax_id(nb_files),stat=ier) + IF (ier /= 0) THEN + WRITE (*,*) ' Could not allocate tax_id of size ', nb_files + STOP 'nctax' + ENDIF +!- + DO if=1,nb_files +!--- + IF (check) THEN + WRITE(*,*) 'ncregular : ', if, names(if) + ENDIF +!--- + iret = NF90_OPEN (names(if),NF90_WRITE,file_id(if)) + iret = NF90_INQUIRE (file_id(if),ndims,nvars,nb_glat,tax_id(if)) +!--- +!-- Get the IDs of the variables +!--- + lon_len = -9999 + lat_len = -9999 + DO in=1,ndims +!----- + iret = NF90_INQUIRE_DIMENSION (file_id(if), in, dim_name, sz) +!----- + IF ( (LEN_TRIM(dim_name) == 1) & + & .AND.(INDEX(dim_name,TRIM(xname)) == 1) ) THEN + lon_dim_id = in + lon_len = sz + ENDIF +!----- + IF ( (LEN_TRIM(dim_name) == 1) & + & .AND.(INDEX(dim_name,TRIM(yname)) == 1) ) THEN + lat_dim_id = in + lat_len = sz + ENDIF +!----- + ENDDO +!--- + IF ( (lon_len == -9999).OR.(lat_len == -9999) ) THEN + WRITE(*,*) 'ncregular : The specified dimensions were not' + WRITE(*,*) 'found in file : ',names(if) + iret = NF90_CLOSE (file_id(if)) + STOP + ENDIF +!--- + IF (check) THEN + WRITE(*,*) 'ncregular : lon_dim_id, lon_len',lon_dim_id,lon_len + WRITE(*,*) 'ncregular : lat_dim_id, lat_len',lat_dim_id,lat_len + ENDIF +!--- +!-- Look for the right variables +!--- + nav_lon_id = -9999 + nav_lat_id = -9999 + DO iv=1,nvars + iret = NF90_INQUIRE_VARIABLE (file_id(if),iv,name=varname) + IF (INDEX(varname,TRIM(lonname)) > 0) THEN + nav_lon_id = iv + ENDIF + IF (INDEX(varname,TRIM(latname)) > 0) THEN + nav_lat_id = iv + ENDIF + ENDDO +!--- + IF ( (nav_lon_id == -9999).OR.(nav_lat_id == -9999) ) THEN + WRITE(*,*) 'ncregular : The specified coordinate fields' + WRITE(*,*) 'were not found in file : ',names(if) + iret = NF90_CLOSE (file_id(if)) + STOP + ENDIF +!--- + IF (check) THEN + WRITE(*,*) 'ncregular : nav_lon_id :', nav_lon_id + WRITE(*,*) 'ncregular : nav_lat_id :', nav_lat_id + ENDIF +!--- +!-- Read variables from file and check if regular +!--- +!-- Do we have the variable to read the +!--- + IF ( alloc_stat_lon < lon_len) THEN + IF ( alloc_stat_lon > 0) THEN + deallocate(lon) + deallocate(lon2) + deallocate(del_lon) + ENDIF + allocate(lon(lon_len)) + allocate(lon2(lon_len)) + allocate(del_lon(lon_len)) + alloc_stat_lon = lon_len + ENDIF +!--- + IF ( alloc_stat_lat < lat_len) THEN + IF ( alloc_stat_lat > 0) THEN + deallocate(lat) + deallocate(lat2) + deallocate(del_lat) + ENDIF + allocate(lat(lat_len)) + allocate(lat2(lat_len)) + allocate(del_lat(lat_len)) + alloc_stat_lat = lat_len + ENDIF +!--- +!-- Read data +!--- + iret = NF90_GET_VAR (file_id(if),nav_lon_id,lon, & + & start=(/1,1/),count=(/lon_len,1/),stride=(/1,1/)) + iret = NF90_GET_VAR (file_id(if),nav_lon_id,lon2, & + & start=(/1,int(lat_len/2)/),count=(/lon_len,1/),stride=(/1,1/)) + del_lon = lon-lon2 +!- + iret = NF90_GET_VAR (file_id(if),nav_lat_id,lat, & + & start=(/1,1/),count=(/1,lat_len/),stride=(/lon_len,1/)) + iret = NF90_GET_VAR (file_id(if),nav_lat_id,lat2, & + & start=(/int(lon_len/2),1/),count=(/1,lat_len/),stride=(/lon_len,1/)) + del_lat = lat-lat2 +!- + regular = ( (MAXVAL(del_lon) < 0.001) & + & .OR.(MAXVAL(del_lat) < 0.001) ) +!--- +!-- Create the new variables +!--- + IF (regular) THEN + IF (check) THEN + WRITE(*,*) 'Regular case' + ENDIF + iret = NF90_REDEF (file_id(if)) + iret = NF90_RENAME_DIM (file_id(if), lon_dim_id, 'lon') + iret = NF90_RENAME_DIM (file_id(if), lat_dim_id, 'lat') + IF (check) THEN + WRITE(*,*) 'Dimensions renamed' + ENDIF + iret = NF90_DEF_VAR (file_id(if), 'lon', NF90_FLOAT, & + & lon_dim_id, lon_id) + iret = NF90_DEF_VAR (file_id(if), 'lat', NF90_FLOAT, & + & lat_dim_id, lat_id) + IF (check) THEN + WRITE(*,*) 'New variables defined' + ENDIF +!----- +!---- Copy attributes +!----- + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'units', & + & file_id(if),lon_id) + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'title', & + & file_id(if),lon_id) + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'valid_max', & + & file_id(if),lon_id) + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'valid_min', & + & file_id(if),lon_id) +!----- + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'units', & + & file_id(if),lat_id) + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'title', & + & file_id(if),lat_id) + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'valid_max', & + & file_id(if),lat_id) + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'valid_min', & + & file_id(if),lat_id) +!----- +!---- Go into write mode +!----- + iret = NF90_ENDDEF (file_id(if)) +!----- +!---- Write data +!----- + iret = NF90_PUT_VAR (file_id(if),lon_id,lon(1:lon_len)) + iret = NF90_PUT_VAR (file_id(if),lat_id,lat(1:lat_len)) +!- + iret = NF90_CLOSE (file_id(if)) + ELSE + WRITE(*,*) 'ncregular : Your grid is not regular' + WRITE(*,*) names(if), 'remains unchanged' + iret = NF90_CLOSE (file_id(if)) + ENDIF +!- + ENDDO +!-------------------- +END PROGRAM ncregular +!- +!=== +!- +SUBROUTINE nct_getarg (argx, nb_files, names, check, & + & xname, yname, lonname, latname) +!--------------------------------------------------------------------- +!- Read the arguments of nctax. +!--------------------------------------------------------------------- + INTEGER,INTENT(in) :: argx + INTEGER, INTENT(out) :: nb_files + CHARACTER(LEN=80),INTENT(out) :: names(argx) + CHARACTER(LEN=20) :: xname, yname, lonname, latname +!- + CHARACTER(LEN=80) :: tmp, tmp_arg + LOGICAL :: check +!--------------------------------------------------------------------- + check = .FALSE. +!- +! Get the number of arguments +!- + nb_files = 0 +!- + xname = 'x' + yname = 'y' + lonname = 'nav_lon' + latname = 'nav_lat' +!- +! Go through the arguments and analyse them one by one +!- + IF (check) WRITE(*,*) 'Start going through the arguments' +!- + IF (argx == 0) THEN + WRITE(*,*) 'To get usage : nctax -h ' + STOP + ENDIF +!- + iread = 1 + DO WHILE (iread <= argx) + iret = getarg(iread,tmp) + IF (check) WRITE(*,*) ' iread, tmp :', iread, tmp + SELECTCASE(tmp) + CASE('-d') + WRITE(*,*) 'DEBUG MODE SELECTED' + check = .TRUE. + iread = iread+1 + CASE('-h') + WRITE(*,*) 'Usage : nregular [options] file1 [file2 ...]' + WRITE(*,*) ' -d : Verbose mode' + WRITE(*,*) ' -h : This output' + STOP + CASE('-dim_lon') + iread = iread+1 + iret = getarg(iread,tmp_arg) + xname = TRIM(tmp_arg) + iread = iread+1 + CASE('-dim_lat') + iread = iread+1 + iret = getarg(iread,tmp_arg) + yname = TRIM(tmp_arg) + iread = iread+1 + CASE('-coo_lon') + iread = iread+1 + iret = getarg(iread,tmp_arg) + lonname = TRIM(tmp_arg) + iread = iread+1 + CASE('-coo_lat') + iread = iread+1 + iret = getarg(iread,tmp_arg) + latname = TRIM(tmp_arg) + iread = iread+1 + CASE DEFAULT + IF (check) WRITE(*,*) 'nct_getarg : CASE default' + IF (INDEX(tmp,'-') /= 1) THEN + nb_files = nb_files+1 + names(nb_files) = tmp + iread = iread+1 + ELSE + WRITE(*,*) "WARNING Unknown option ",tmp + WRITE(*,*) "For ore information : nctax -h" + ENDIF + END SELECT + ENDDO +!- + IF (check) THEN + WRITE(*,*) ' nct_getarg : output >> ' + WRITE(*,*) '>> nb_files : ', nb_files + WRITE(*,*) '>> names :', (names(ii), ii=1,nb_files) + ENDIF +!------------------------ +END SUBROUTINE nct_getarg diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/wc.db b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/wc.db new file mode 100644 index 0000000..d4cacf3 Binary files /dev/null and b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/wc.db differ diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/.svn/wc.db-journal b/NEMO_4.0.4_surge/ext/IOIPSL/.svn/wc.db-journal new file mode 100644 index 0000000..e69de29 diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/IOIPSL_License_CeCILL.txt b/NEMO_4.0.4_surge/ext/IOIPSL/IOIPSL_License_CeCILL.txt new file mode 100644 index 0000000..784fc1a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/IOIPSL_License_CeCILL.txt @@ -0,0 +1,36 @@ +The following licence information concerns ONLY the IOIPSL directory +==================================================================== + +Copyright (C) Institut Pierre Simon Laplace : IPSL + +This software is composed by a set of subroutines working as an +interface between climate models and NETCDF files following CF +convention. Library sources, examples of use and tools based on +IOIPSL are provided. This library requires NetCDF library : +http://www.unidata.ucar.edu/software/netcdf/ + +This software is governed by the CeCILL license under French law and +abiding by the rules of distribution of free software. You can use, +modify and/or redistribute the software under the terms of the CeCILL +license as circulated by CEA, CNRS and INRIA at the following URL +"http://www.cecill.info". + +As a counterpart to the access to the source code and rights to copy, +modify and redistribute granted by the license, users are provided only +with a limited warranty and the software's author, the holder of the +economic rights, and the successive licensors have only limited +liability. + +In this respect, the user's attention is drawn to the risks associated +with loading, using, modifying and/or developing or reproducing the +software by the user in light of its specific status of free software, +that may mean that it is complicated to manipulate, and that also +therefore means that it is reserved for developers and experienced +professionals having in-depth computer knowledge. Users are therefore +encouraged to load and test the software's suitability as regards their +requirements in conditions enabling the security of their systems and/or +data to be ensured and, more generally, to use and operate it in the +same conditions as regards security. + +The fact that you are presently reading this means that you have had +knowledge of the CeCILL license and that you accept its terms. diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/calendar.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/calendar.f90 new file mode 100644 index 0000000..9a034a4 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/calendar.f90 @@ -0,0 +1,1044 @@ +MODULE calendar +!- +!$Id: calendar.f90 2459 2010-12-07 11:17:48Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- This is the calendar which going to be used to do all +!- calculations on time. Three types of calendars are possible : +!- +!- - gregorian : +!- The normal calendar. The time origin for the +!- julian day in this case is 24 Nov -4713 +!- (other names : 'standard','proleptic_gregorian') +!- - noleap : +!- A 365 day year without leap years. +!- The origin for the julian days is in this case 1 Jan 0 +!- (other names : '365_day','365d') +!- - all_leap : +!- A 366 day year with leap years. +!- The origin for the julian days is in this case ???? +!- (other names : '366_day','366d' +!- - julian : +!- same as gregorian, but with all leap century years +!- - xxxd : +!- Year of xxx days with month of equal length. +!- The origin for the julian days is then also 1 Jan 0 +!- +!- As one can see it is difficult to go from one calendar to the other. +!- All operations involving julian days will be wrong. +!- This calendar will lock as soon as possible +!- the length of the year and forbid any further modification. +!- +!- For the non leap-year calendar the method is still brute force. +!- We need to find an Integer series which takes care of the length +!- of the various month. (Jan) +!- +!- one_day : one day in seconds +!- one_year : one year in days +!--------------------------------------------------------------------- + USE stringop,ONLY : strlowercase + USE errioipsl,ONLY : ipslerr +!- + PRIVATE + PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, & + & ioget_calendar,ioget_mon_len,ioget_year_len,itau2date, & + & ioget_timestamp,ioconf_startdate,itau2ymds, & + & time_diff,time_add,lock_calendar +!- + INTERFACE ioget_calendar + MODULE PROCEDURE & + & ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str + END INTERFACE +!- + INTERFACE ioconf_startdate + MODULE PROCEDURE & + & ioconf_startdate_simple,ioconf_startdate_internal, & + & ioconf_startdate_ymds + END INTERFACE +!- + REAL,PARAMETER :: one_day = 86400.0 + LOGICAL,SAVE :: lock_startdate = .FALSE. +!- + CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX' +!- +!- Description of calendar +!- + CHARACTER(LEN=20),SAVE :: calendar_used="gregorian" + LOGICAL,SAVE :: lock_one_year = .FALSE. + REAL,SAVE :: one_year = 365.2425 + INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/) +!- + CHARACTER(LEN=3),PARAMETER :: & + & cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', & + & 'JUL','AUG','SEP','OCT','NOV','DEC'/) +!- + REAL,SAVE :: start_day,start_sec +!- +CONTAINS +!- +!=== +!- +SUBROUTINE lock_calendar (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "lock_calendar" routine +!! allows to lock or unlock the calendar, +!! and to know the current status of the calendar. +!! Be careful ! +!! +!! SUBROUTINE lock_calendar (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the calendar +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the calendar +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = lock_one_year + ENDIF + IF (PRESENT(new_status)) THEN + lock_one_year = new_status + ENDIF +!--------------------------- +END SUBROUTINE lock_calendar +!- +!=== +!- +SUBROUTINE ymds2ju (year,month,day,sec,julian) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL,INTENT(IN) :: sec +!- + REAL,INTENT(OUT) :: julian +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!- + julian = julian_day+julian_sec/one_day +!--------------------- +END SUBROUTINE ymds2ju +!- +!=== +!- +SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!--------------------------------------------------------------------- +!- Converts year, month, day and seconds into a julian day +!- +!- In 1968 in a letter to the editor of Communications of the ACM +!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel +!- and Thomas C. Van Flandern presented such an algorithm. +!- +!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm +!- +!- In the case of the Gregorian calendar we have chosen to use +!- the Lilian day numbers. This is the day counter which starts +!- on the 15th October 1582. +!- This is the day at which Pope Gregory XIII introduced the +!- Gregorian calendar. +!- Compared to the true Julian calendar, which starts some +!- 7980 years ago, the Lilian days are smaler and are dealt with +!- easily on 32 bit machines. With the true Julian days you can only +!- the fraction of the day in the real part to a precision of +!- a 1/4 of a day with 32 bits. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL,INTENT(IN) :: sec +!- + INTEGER,INTENT(OUT) :: julian_day + REAL,INTENT(OUT) :: julian_sec +!- + INTEGER :: jd,m,y,d,ml +!--------------------------------------------------------------------- + lock_one_year = .TRUE. +!- + m = month + y = year + d = day +!- +!- We deduce the calendar from the length of the year as it +!- is faster than an INDEX on the calendar variable. +!- + IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN +!-- "Gregorian" + jd = (1461*(y+4800+INT((m-14)/12)))/4 & + & +(367*(m-2-12*(INT((m-14)/12))))/12 & + & -(3*((y+4900+INT((m-14)/12))/100))/4 & + & +d-32075 + jd = jd-2299160 + ELSE IF ( (ABS(one_year-365.0) <= EPSILON(one_year)) & + & .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN +!-- "No leap" or "All leap" + ml = SUM(mon_len(1:m-1)) + jd = y*NINT(one_year)+ml+(d-1) + ELSE +!-- Calendar with regular month + ml = NINT(one_year/12.) + jd = y*NINT(one_year)+(m-1)*ml+(d-1) + ENDIF +!- + julian_day = jd + julian_sec = sec +!------------------------------ +END SUBROUTINE ymds2ju_internal +!- +!=== +!- +SUBROUTINE ju2ymds (julian,year,month,day,sec) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(IN) :: julian +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL,INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + julian_day = INT(julian) + julian_sec = (julian-julian_day)*one_day +!- + CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec) +!--------------------- +END SUBROUTINE ju2ymds +!- +!=== +!- +SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec) +!--------------------------------------------------------------------- +!- This subroutine computes from the julian day the year, +!- month, day and seconds +!- +!- In 1968 in a letter to the editor of Communications of the ACM +!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel +!- and Thomas C. Van Flandern presented such an algorithm. +!- +!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm +!- +!- In the case of the Gregorian calendar we have chosen to use +!- the Lilian day numbers. This is the day counter which starts +!- on the 15th October 1582. This is the day at which Pope +!- Gregory XIII introduced the Gregorian calendar. +!- Compared to the true Julian calendar, which starts some 7980 +!- years ago, the Lilian days are smaler and are dealt with easily +!- on 32 bit machines. With the true Julian days you can only the +!- fraction of the day in the real part to a precision of a 1/4 of +!- a day with 32 bits. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: julian_day + REAL,INTENT(IN) :: julian_sec +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL,INTENT(OUT) :: sec +!- + INTEGER :: l,n,i,jd,j,d,m,y,ml + INTEGER :: add_day + REAL :: eps_day +!--------------------------------------------------------------------- + eps_day = SPACING(one_day) + lock_one_year = .TRUE. +!- + jd = julian_day + sec = julian_sec + IF (sec > (one_day-eps_day)) THEN + add_day = INT(sec/one_day) + sec = sec-add_day*one_day + jd = jd+add_day + ENDIF + IF (sec < -eps_day) THEN + sec = sec+one_day + jd = jd-1 + ENDIF +!- + IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN +!-- Gregorian + jd = jd+2299160 +!- + l = jd+68569 + n = (4*l)/146097 + l = l-(146097*n+3)/4 + i = (4000*(l+1))/1461001 + l = l-(1461*i)/4+31 + j = (80*l)/2447 + d = l-(2447*j)/80 + l = j/11 + m = j+2-(12*l) + y = 100*(n-49)+i+l + ELSE IF ( (ABS(one_year-365.0) <= EPSILON(one_year)) & + & .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN +!-- No leap or All leap + y = jd/NINT(one_year) + l = jd-y*NINT(one_year) + m = 1 + ml = 0 + DO WHILE (ml+mon_len(m) <= l) + ml = ml+mon_len(m) + m = m+1 + ENDDO + d = l-ml+1 + ELSE +!-- others + ml = NINT(one_year/12.) + y = jd/NINT(one_year) + l = jd-y*NINT(one_year) + m = (l/ml)+1 + d = l-(m-1)*ml+1 + ENDIF +!- + day = d + month = m + year = y +!------------------------------ +END SUBROUTINE ju2ymds_internal +!- +!=== +!- +SUBROUTINE tlen2itau (input_str,dt,date,itau) +!--------------------------------------------------------------------- +!- This subroutine transforms a string containing a time length +!- into a number of time steps. +!- To do this operation the date (in julian days is needed as the +!- length of the month varies. +!- The following convention is used : +!- n : n time steps +!- nS : n seconds is transformed into itaus +!- nH : n hours +!- nD : n days +!- nM : n month +!- nY : n years +!- Combinations are also possible +!- nYmD : nyears plus m days ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: input_str + REAL,INTENT(IN) :: dt,date +!- + INTEGER,INTENT(OUT) :: itau +!- + INTEGER :: y_pos,m_pos,d_pos,h_pos,s_pos + INTEGER :: read_time + CHARACTER(LEN=13) :: fmt + CHARACTER(LEN=80) :: tmp_str +!- + INTEGER :: year,month,day + REAL :: sec,date_new,dd,ss +!--------------------------------------------------------------------- + itau = 0 + CALL ju2ymds (date,year,month,day,sec) +!- + y_pos = MAX(INDEX(input_str,'y'),INDEX(input_str,'Y')) + m_pos = MAX(INDEX(input_str,'m'),INDEX(input_str,'M')) + d_pos = MAX(INDEX(input_str,'d'),INDEX(input_str,'D')) + h_pos = MAX(INDEX(input_str,'h'),INDEX(input_str,'H')) + s_pos = MAX(INDEX(input_str,'s'),INDEX(input_str,'S')) +!- + IF (MAX(y_pos,m_pos,d_pos,s_pos) > 0) THEN + tmp_str = input_str + DO WHILE ( MAX(y_pos,m_pos,d_pos,s_pos) > 0) +!---- WRITE(*,*) tmp_str +!---- WRITE(*,*) y_pos,m_pos,d_pos,s_pos + IF (y_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') y_pos-1 + READ(tmp_str(1:y_pos-1),fmt) read_time + CALL ymds2ju (year+read_time,month,day,sec,date_new) + dd = date_new-date + ss = INT(dd)*one_day+dd-INT(dd) + itau = itau+NINT(ss/dt) + tmp_str = tmp_str(y_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (m_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') m_pos-1 + READ(tmp_str(1:m_pos-1),fmt) read_time + CALL ymds2ju (year,month+read_time,day,sec,date_new) + dd = date_new-date + ss = INT(dd)*one_day+dd-INT(dd) + itau = itau+NINT(ss/dt) + tmp_str = tmp_str(m_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (d_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') d_pos-1 + READ(tmp_str(1:d_pos-1),fmt) read_time + itau = itau+NINT(read_time*one_day/dt) + tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (h_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') h_pos-1 + READ(tmp_str(1:h_pos-1),fmt) read_time + itau = itau+NINT(read_time*60.*60./dt) + tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str)) + ELSE IF (s_pos > 0) THEN + WRITE(fmt,'("(I",I10.10,")")') s_pos-1 + READ(tmp_str(1:s_pos-1),fmt) read_time + itau = itau+NINT(read_time/dt) + tmp_str = tmp_str(s_pos+1:LEN_TRIM(tmp_str)) + ENDIF +!- + y_pos = MAX(INDEX(tmp_str,'y'),INDEX(tmp_str,'Y')) + m_pos = MAX(INDEX(tmp_str,'m'),INDEX(tmp_str,'M')) + d_pos = MAX(INDEX(tmp_str,'d'),INDEX(tmp_str,'D')) + h_pos = MAX(INDEX(tmp_str,'h'),INDEX(tmp_str,'H')) + s_pos = MAX(INDEX(tmp_str,'s'),INDEX(tmp_str,'S')) + ENDDO + ELSE + WRITE(fmt,'("(I",I10.10,")")') LEN_TRIM(input_str) + READ(input_str(1:LEN_TRIM(input_str)),fmt) itau + ENDIF +!----------------------- +END SUBROUTINE tlen2itau +!- +!=== +!- +REAL FUNCTION itau2date (itau,date0,deltat) +!--------------------------------------------------------------------- +!- This function transforms itau into a date. The date with which +!- the time axis is going to be labeled +!- +!- INPUT +!- itau : current time step +!- date0 : Date at which itau was equal to 0 +!- deltat : time step between itau s +!- +!- OUTPUT +!- itau2date : Date for the given itau +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: itau + REAL :: date0,deltat +!--------------------------------------------------------------------- + itau2date = REAL(itau)*deltat/one_day+date0 +!--------------------- +END FUNCTION itau2date +!- +!=== +!- +SUBROUTINE itau2ymds (itau,deltat,year,month,day,sec) +!--------------------------------------------------------------------- +!- This subroutine transforms itau into a date. The date with which +!- the time axis is going to be labeled +!- +!- INPUT +!- itau : current time step +!- deltat : time step between itau s +!- +!- OUTPUT +!- year : year +!- month : month +!- day : day +!- sec : seconds since midnight +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: itau + REAL,INTENT(IN) :: deltat +!- + INTEGER,INTENT(OUT) :: year,month,day + REAL,INTENT(OUT) :: sec +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + IF (.NOT.lock_startdate) THEN + CALL ipslerr (2,'itau2ymds', & + & 'You try to call this function, itau2ymds, but you didn''t', & + & ' call ioconf_startdate to initialize date0 in calendar.', & + & ' Please call ioconf_startdate before itau2ymds.') + ENDIF + julian_day = start_day + julian_sec = start_sec+REAL(itau)*deltat + CALL ju2ymds_internal (julian_day,julian_sec,year,month,day,sec) +!----------------------- +END SUBROUTINE itau2ymds +!- +!=== +!- +REAL FUNCTION dtchdate (itau,date0,old_dt,new_dt) +!--------------------------------------------------------------------- +!- This function changes the date so that the simulation can +!- continue with the same itau but a different dt. +!- +!- INPUT +!- itau : current time step +!- date0 : Date at which itau was equal to 0 +!- old_dt : Old time step between itaus +!- new_dt : New time step between itaus +!- +!- OUTPUT +!- dtchdate : Date for the given itau +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: itau + REAL,INTENT(IN) :: date0,old_dt,new_dt +!- + REAL :: rtime +!--------------------------------------------------------------------- + rtime = itau2date (itau,date0,old_dt) + dtchdate = rtime-REAL(itau)*new_dt/one_day +!-------------------- +END FUNCTION dtchdate +!- +!=== +!- +SUBROUTINE isittime & + & (itau,date0,dt,freq,last_action,last_check,do_action) +!--------------------------------------------------------------------- +!- This subroutine checks the time as come for a given action. +!- This is computed from the current time-step(itau). +!- Thus we need to have the time delta (dt), the frequency +!- of the action (freq) and the last time it was done +!- (last_action in units of itau). +!- In order to extrapolate when will be the next check we need +!- the time step of the last call (last_check). +!- +!- The test is done on the following condition : +!- the distance from the current time to the time for the next +!- action is smaller than the one from the next expected +!- check to the next action. +!- When the test is done on the time steps simplifications make +!- it more difficult to read in the code. +!- For the real time case it is easier to understand ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: itau + REAL,INTENT(IN) :: dt,freq + INTEGER,INTENT(IN) :: last_action,last_check + REAL,INTENT(IN) :: date0 +!- + LOGICAL,INTENT(OUT) :: do_action +!- + REAL :: dt_action,dt_check + REAL :: date_last_act,date_next_check,date_next_act, & + & date_now,date_mp1,date_mpf + INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau + INTEGER :: yearp,dayp + REAL :: sec,secp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) THEN + WRITE(*,*) & + & "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check + ENDIF +!- + IF (last_check >= 0) THEN + dt_action = (itau-last_action)*dt + dt_check = (itau-last_check)*dt + next_check_itau = itau+(itau-last_check) +!- +!-- We are dealing with frequencies in seconds and thus operation +!-- can be done on the time steps. +!- + IF (freq > 0) THEN + IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN + do_action = .TRUE. + ELSE + do_action = .FALSE. + ENDIF +!- +!---- Here we deal with frequencies in month and work on julian days. +!- + ELSE + date_now = itau2date (itau,date0,dt) + date_last_act = itau2date (last_action,date0,dt) + CALL ju2ymds (date_last_act,year,month,day,sec) + monthp1 = month-freq + yearp = year +!- +!---- Here we compute what logically should be the next month +!- + DO WHILE (monthp1 >= 13) + yearp = yearp+1 + monthp1 = monthp1-12 + END DO + CALL ymds2ju (yearp,monthp1,day,sec,date_mpf) +!- +!---- But it could be that because of a shorter month or a bad +!---- starting date that we end up further than we should be. +!---- Thus we compute the first day of the next month. +!---- We can not be beyond this date and if we are close +!---- then we will take it as it is better. +!- + monthp1 = month+ABS(freq) + yearp=year + DO WHILE (monthp1 >= 13) + yearp = yearp+1 + monthp1 = monthp1-12 + END DO + dayp = 1 + secp = 0.0 + CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1) +!- +!---- If date_mp1 is smaller than date_mpf or only less than 4 days +!---- larger then we take it. This needed to ensure that short month +!---- like February do not mess up the thing ! +!- + IF (date_mp1-date_mpf < 4.) THEN + date_next_act = date_mp1 + ELSE + date_next_act = date_mpf + ENDIF + date_next_check = itau2date (next_check_itau,date0,dt) +!- +!---- Transform the dates into time-steps for the needed precisions. +!- + next_act_itau = & + & last_action+INT((date_next_act-date_last_act)*(one_day/dt)) +!----- + IF ( ABS(itau-next_act_itau) & + & <= ABS( next_check_itau-next_act_itau)) THEN + do_action = .TRUE. + IF (check) THEN + WRITE(*,*) & + & 'ACT-TIME : itau, next_act_itau, next_check_itau : ', & + & itau,next_act_itau,next_check_itau + CALL ju2ymds (date_now,year,month,day,sec) + WRITE(*,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec + WRITE(*,*) & + & 'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf + ENDIF + ELSE + do_action = .FALSE. + ENDIF + ENDIF +!- + IF (check) THEN + WRITE(*,*) "isittime 2.0 ", & + & date_next_check,date_next_act,ABS(dt_action-freq), & + & ABS(dt_action+dt_check-freq),dt_action,dt_check, & + & next_check_itau,do_action + ENDIF + ELSE + do_action=.FALSE. + ENDIF +!---------------------- +END SUBROUTINE isittime +!- +!=== +!- +SUBROUTINE ioconf_calendar (str) +!--------------------------------------------------------------------- +!- This routine allows to configure the calendar to be used. +!- This operation is only allowed once and the first call to +!- ymds2ju or ju2ymsd will lock the current configuration. +!- the argument to ioconf_calendar can be any of the following : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: str +!- + INTEGER :: leng,ipos + CHARACTER(LEN=20) :: str_w +!--------------------------------------------------------------------- +!- +! Clean up the string ! +!- + str_w = str + CALL strlowercase (str_w) +!- + IF (.NOT.lock_one_year) THEN +!--- + lock_one_year=.TRUE. +!--- + SELECT CASE(TRIM(str_w)) + CASE('gregorian','standard','proleptic_gregorian') + calendar_used = 'gregorian' + one_year = 365.2425 + mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) + CASE('noleap','365_day','365d') + calendar_used = 'noleap' + one_year = 365.0 + mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) + CASE('all_leap','366_day','366d') + calendar_used = 'all_leap' + one_year = 366.0 + mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/) + CASE('360_day','360d') + calendar_used = '360d' + one_year = 360.0 + mon_len(:)=(/30,30,30,30,30,30,30,30,30,30,30,30/) + CASE('julian') + calendar_used = 'julian' + one_year = 365.25 + mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/) + CASE DEFAULT + ipos = INDEX(str_w,'d') + IF (ipos == 4) THEN + READ(str_w(1:3),'(I3)') leng + IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN + calendar_used = str_w + one_year = leng + mon_len(:) = leng/12 + ELSE + CALL ipslerr (3,'ioconf_calendar', & + & 'The length of the year as to be a modulo of 12', & + & 'so that it can be divided into 12 month of equal length', & + & TRIM(str_w)) + ENDIF + ELSE + CALL ipslerr (3,'ioconf_calendar', & + & 'Unrecognized input, please check the man pages.', & + & TRIM(str_w),' ') + ENDIF + END SELECT + ELSE IF (TRIM(str_w) /= TRIM(calendar_used)) THEN + WRITE(str_w,'(f10.4)') one_year + CALL ipslerr (2,'ioconf_calendar', & + & 'The calendar was already used or configured to : '// & + & TRIM(calendar_used)//'.', & + & 'You are not allowed to change it to : '//TRIM(str)//'.', & + & 'The following length of year is used : '//TRIM(ADJUSTL(str_w))) + ENDIF +!----------------------------- +END SUBROUTINE ioconf_calendar +!- +!=== +!- +SUBROUTINE ioconf_startdate_simple (julian) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(IN) :: julian +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + julian_day = INT(julian) + julian_sec = (julian-julian_day)*one_day +!- + CALL ioconf_startdate_internal (julian_day,julian_sec) +!------------------------------------- +END SUBROUTINE ioconf_startdate_simple +!- +!=== +!- +SUBROUTINE ioconf_startdate_ymds (year,month,day,sec) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month,day + REAL,INTENT(IN) :: sec +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec) +!- + CALL ioconf_startdate_internal (julian_day,julian_sec) +!----------------------------------- +END SUBROUTINE ioconf_startdate_ymds +!- +!=== +!- +SUBROUTINE ioconf_startdate_internal (julian_day,julian_sec) +!--------------------------------------------------------------------- +! This subroutine allows to set the startdate for later +! use. It allows the applications to access the date directly from +! the timestep. In order to avoid any problems the start date will +! be locked and can not be changed once set. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: julian_day + REAL,INTENT(IN) :: julian_sec +!- + CHARACTER(len=70) :: str70a,str70b +!--------------------------------------------------------------------- + IF (.NOT.lock_startdate) THEN + start_day = julian_day + start_sec = julian_sec + lock_startdate = .TRUE. + ELSE + WRITE(str70a,'("The date you tried to set : ",f10.4)') & + & julian_day,julian_sec/one_day + WRITE(str70b, & + & '("The date which was already set in the calendar : ",f10.4)') & + & start_day+start_sec/one_day + CALL ipslerr (2,'ioconf_startdate', & + & 'The start date has already been set and you tried to change it', & + & str70a,str70b) + ENDIF +!--------------------------------------- +END SUBROUTINE ioconf_startdate_internal +!- +!=== +!- +SUBROUTINE ioget_calendar_str (str) +!--------------------------------------------------------------------- +!- This subroutine returns the name of the calendar used here. +!- Three options exist : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!- +!- This routine will lock the calendar. +!- You do not want it to change after your inquiry. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(OUT) :: str +!--------------------------------------------------------------------- + lock_one_year = .TRUE. +!- + str = calendar_used +!-------------------------------- +END SUBROUTINE ioget_calendar_str +!- +!=== +!- +SUBROUTINE ioget_calendar_real1 (long_year) +!--------------------------------------------------------------------- +!- This subroutine returns the name of the calendar used here. +!- Three options exist : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!- +!- This routine will lock the calendar. +!- You do not want it to change after your inquiry. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(OUT) :: long_year +!--------------------------------------------------------------------- + long_year = one_year + lock_one_year = .TRUE. +!---------------------------------- +END SUBROUTINE ioget_calendar_real1 +!- +!=== +!- +SUBROUTINE ioget_calendar_real2 (long_year,long_day) +!--------------------------------------------------------------------- +!- This subroutine returns the name of the calendar used here. +!- Three options exist : +!- - gregorian : This is the gregorian calendar (default here) +!- - noleap : A calendar without leap years = 365 days +!- - xxxd : A calendar of xxx days (has to be a modulo of 12) +!- with 12 month of equal length +!- +!- This routine will lock the calendar. +!- You do not want it to change after your inquiry. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL,INTENT(OUT) :: long_year,long_day +!--------------------------------------------------------------------- + long_year = one_year + long_day = one_day + lock_one_year = .TRUE. +!---------------------------------- +END SUBROUTINE ioget_calendar_real2 +!- +!=== +!- +INTEGER FUNCTION ioget_mon_len (year,month) +!!-------------------------------------------------------------------- +!! The "ioget_mon_len" function returns +!! the number of days in a "month" of a "year", +!! in the current calendar. +!! +!! INTEGER FUNCTION ioget_mon_len (year,month) +!! +!! INPUT +!! +!! (I) year : year +!! (I) month : month in the year (1 --> 12) +!! +!! OUTPUT +!! +!! (I) ioget_mon_len : number of days in the month +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year,month +!- + INTEGER :: ml +!--------------------------------------------------------------------- + IF ( (month >= 1).AND.(month <= 12) ) THEN + IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN +!---- "Gregorian" or "Julian" + ml = mon_len(month) + IF (month == 2) THEN + IF (ABS(one_year-365.2425) <= EPSILON(one_year) ) THEN +!-------- "Gregorian" + IF ( ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) & + .OR.(MOD(year,400) == 0) ) THEN + ml = ml+1 + ENDIF + ELSE +!-------- "Julian" + IF (MOD(year,4) == 0) THEN + ml = ml+1 + ENDIF + ENDIF + ENDIF + ioget_mon_len = ml + ELSE +!---- "No leap" or "All leap" or "Calendar with regular month" + ioget_mon_len = mon_len(month) + ENDIF + ELSE + CALL ipslerr (3,'ioget_mon_len', & + & 'The number of the month','must be between','1 and 12') + ENDIF +!------------------------- +END FUNCTION ioget_mon_len +!- +!=== +!- +INTEGER FUNCTION ioget_year_len (year) +!!-------------------------------------------------------------------- +!! The "ioget_year_len" function returns +!! the number of days in "year", in the current calendar. +!! +!! INTEGER FUNCTION ioget_year_len (year) +!! +!! INPUT +!! +!! (I) year : year +!! +!! OUTPUT +!! +!! (I) ioget_year_len : number of days in the year +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year +!- + INTEGER :: yl +!--------------------------------------------------------------------- + SELECT CASE(TRIM(calendar_used)) + CASE('gregorian') + yl = 365 + IF ( ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) & + .OR.(MOD(year,400) == 0) ) THEN + yl = yl+1 + ENDIF + CASE('julian') + yl = 365 + IF (MOD(year,4) == 0) THEN + yl = yl+1 + ENDIF + CASE DEFAULT + yl = NINT(one_year) + END SELECT + ioget_year_len = yl +!-------------------------- +END FUNCTION ioget_year_len +!- +!=== +!- +SUBROUTINE ioget_timestamp (string) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=30),INTENT(OUT) :: string +!- + INTEGER :: date_time(8) + CHARACTER(LEN=10) :: bigben(3) +!--------------------------------------------------------------------- + IF (INDEX(time_stamp,'XXXXXX') > 0) THEN + CALL DATE_AND_TIME (bigben(1),bigben(2),bigben(3),date_time) +!--- + WRITE(time_stamp, & + & "(I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,' GMT',a5)") & + & date_time(1),cal(date_time(2)),date_time(3),date_time(5), & + & date_time(6),date_time(7),bigben(3) + ENDIF +!- + string = time_stamp +!----------------------------- +END SUBROUTINE ioget_timestamp +!- +!=== +!- +SUBROUTINE time_add & + & (year_s,month_s,day_s,sec_s,sec_increment, & + & year_e,month_e,day_e,sec_e) +!--------------------------------------------------------------------- +!- This subroutine allows to increment a date by a number of seconds. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year_s,month_s,day_s + REAL,INTENT(IN) :: sec_s +!- +! Time in seconds to be added to the date +!- + REAL,INTENT(IN) :: sec_increment +!- + INTEGER,INTENT(OUT) :: year_e,month_e,day_e + REAL,INTENT(OUT) :: sec_e +!- + INTEGER :: julian_day + REAL :: julian_sec +!--------------------------------------------------------------------- + CALL ymds2ju_internal & + & (year_s,month_s,day_s,sec_s,julian_day,julian_sec) +!- + julian_sec = julian_sec+sec_increment +!- + CALL ju2ymds_internal & + & (julian_day,julian_sec,year_e,month_e,day_e,sec_e) +!---------------------- +END SUBROUTINE time_add +!- +!=== +!- +SUBROUTINE time_diff & + & (year_s,month_s,day_s,sec_s,year_e,month_e,day_e,sec_e,sec_diff) +!--------------------------------------------------------------------- +!- This subroutine allows to determine the number of seconds +!- between two dates. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: year_s,month_s,day_s + REAL,INTENT(IN) :: sec_s + INTEGER,INTENT(IN) :: year_e,month_e,day_e + REAL,INTENT(IN) :: sec_e +!- +! Time in seconds between the two dates +!- + REAL,INTENT(OUT) :: sec_diff +!- + INTEGER :: julian_day_s,julian_day_e,day_diff + REAL :: julian_sec_s,julian_sec_e +!--------------------------------------------------------------------- + CALL ymds2ju_internal & + & (year_s,month_s,day_s,sec_s,julian_day_s,julian_sec_s) + CALL ymds2ju_internal & + & (year_e,month_e,day_e,sec_e,julian_day_e,julian_sec_e) +!- + day_diff = julian_day_e-julian_day_s + sec_diff = julian_sec_e-julian_sec_s +!- + sec_diff = sec_diff+day_diff*one_day +!----------------------- +END SUBROUTINE time_diff +!- +!=== +!- +END MODULE calendar diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/defprec.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/defprec.f90 new file mode 100644 index 0000000..67cda8f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/defprec.f90 @@ -0,0 +1,22 @@ +MODULE defprec +!- +! $Id: defprec.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!!-------------------------------------------------------------------- +!! The module "defprec" set default precision for computation +!! +!! This module should be used by every modules +!! to keep the right precision for every variable +!!-------------------------------------------------------------------- +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER,PARAMETER :: i_1=SELECTED_INT_KIND(2) + INTEGER,PARAMETER :: i_2=SELECTED_INT_KIND(4) + INTEGER,PARAMETER :: i_4=SELECTED_INT_KIND(9) + INTEGER,PARAMETER :: i_8=SELECTED_INT_KIND(13) + INTEGER,PARAMETER :: r_4=SELECTED_REAL_KIND(6,37) + INTEGER,PARAMETER :: r_8=SELECTED_REAL_KIND(15,307) + INTEGER,PARAMETER :: i_std=i_4, r_std=r_8 +!----------------- +END MODULE defprec diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/errioipsl.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/errioipsl.f90 new file mode 100644 index 0000000..d9ca60e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/errioipsl.f90 @@ -0,0 +1,215 @@ +MODULE errioipsl +!- +!$Id: errioipsl.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg +!- + INTEGER :: n_l=6, ilv_cur=0, ilv_max=0 + LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE. +!- +!=== +CONTAINS +!=== +SUBROUTINE ipslnlf (new_number,old_number) +!!-------------------------------------------------------------------- +!! The "ipslnlf" routine allows to know and modify +!! the current logical number for the messages. +!! +!! SUBROUTINE ipslnlf (new_number,old_number) +!! +!! Optional INPUT argument +!! +!! (I) new_number : new logical number of the file +!! +!! Optional OUTPUT argument +!! +!! (I) old_number : current logical number of the file +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(IN) :: new_number + INTEGER,OPTIONAL,INTENT(OUT) :: old_number +!--------------------------------------------------------------------- + IF (PRESENT(old_number)) THEN + old_number = n_l + ENDIF + IF (PRESENT(new_number)) THEN + n_l = new_number + ENDIF +!--------------------- +END SUBROUTINE ipslnlf +!=== +SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!! The "ipslerr" routine +!! allows to handle the messages to the user. +!! +!! INPUT +!! +!! plev : Category of message to be reported to the user +!! 1 = Note to the user +!! 2 = Warning to the user +!! 3 = Fatal error +!! pcname : Name of subroutine which has called ipslerr +!! pstr1 +!! pstr2 : Strings containing the explanations to the user +!! pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + ilv_cur = plev + ilv_max = MAX(ilv_max,plev) + WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3) + ENDIF + IF ( (plev == 3).AND.lact_mode) THEN + WRITE(n_l,'("Fatal error from IOIPSL. STOP in ipslerr with code")') + STOP 1 + ENDIF +!--------------------- +END SUBROUTINE ipslerr +!=== +SUBROUTINE ipslerr_act (new_mode,old_mode) +!!-------------------------------------------------------------------- +!! The "ipslerr_act" routine allows to know and modify +!! the current "action mode" for the error messages, +!! and reinitialize the error level values. +!! +!! SUBROUTINE ipslerr_act (new_mode,old_mode) +!! +!! Optional INPUT argument +!! +!! (I) new_mode : new error action mode +!! .TRUE. -> STOP in case of fatal error +!! .FALSE. -> CONTINUE in case of fatal error +!! +!! Optional OUTPUT argument +!! +!! (I) old_mode : current error action mode +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_mode + LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode +!--------------------------------------------------------------------- + IF (PRESENT(old_mode)) THEN + old_mode = lact_mode + ENDIF + IF (PRESENT(new_mode)) THEN + lact_mode = new_mode + ENDIF + ilv_cur = 0 + ilv_max = 0 +!------------------------- +END SUBROUTINE ipslerr_act +!=== +SUBROUTINE ipslerr_inq (current_level,maximum_level) +!!-------------------------------------------------------------------- +!! The "ipslerr_inq" routine allows to know +!! the current level of the error messages +!! and the maximum level encountered since the +!! last call to "ipslerr_act". +!! +!! SUBROUTINE ipslerr_inq (current_level,maximum_level) +!! +!! Optional OUTPUT argument +!! +!! (I) current_level : current error level +!! (I) maximum_level : maximum error level +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level +!--------------------------------------------------------------------- + IF (PRESENT(current_level)) THEN + current_level = ilv_cur + ENDIF + IF (PRESENT(maximum_level)) THEN + maximum_level = ilv_max + ENDIF +!------------------------- +END SUBROUTINE ipslerr_inq +!=== +SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3) +!--------------------------------------------------------------------- +!- INPUT +!- plev : Category of message to be reported to the user +!- 1 = Note to the user +!- 2 = Warning to the user +!- 3 = Fatal error +!- pcname : Name of subroutine which has called histerr +!- pstr1 +!- pstr2 : String containing the explanations to the user +!- pstr3 +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: plev + CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3 +!- + CHARACTER(LEN=30),DIMENSION(3) :: pemsg = & + & (/ "NOTE TO THE USER FROM ROUTINE ", & + & "WARNING FROM ROUTINE ", & + & "FATAL ERROR FROM ROUTINE " /) +!--------------------------------------------------------------------- + IF ( (plev >= 1).AND.(plev <= 3) ) THEN + WRITE(*,'(" ")') + WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname) + WRITE(*,'(" --> ",A)') pstr1 + WRITE(*,'(" --> ",A)') pstr2 + WRITE(*,'(" --> ",A)') pstr3 + ENDIF + IF (plev == 3) THEN + STOP 'Fatal error from IOIPSL. See stdout for more details' + ENDIF +!--------------------- +END SUBROUTINE histerr +!=== +SUBROUTINE ipsldbg (new_status,old_status) +!!-------------------------------------------------------------------- +!! The "ipsldbg" routine +!! allows to activate or deactivate the debug, +!! and to know the current status of the debug. +!! +!! SUBROUTINE ipsldbg (new_status,old_status) +!! +!! Optional INPUT argument +!! +!! (L) new_status : new status of the debug +!! +!! Optional OUTPUT argument +!! +!! (L) old_status : current status of the debug +!!-------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,OPTIONAL,INTENT(IN) :: new_status + LOGICAL,OPTIONAL,INTENT(OUT) :: old_status +!--------------------------------------------------------------------- + IF (PRESENT(old_status)) THEN + old_status = ioipsl_debug + ENDIF + IF (PRESENT(new_status)) THEN + ioipsl_debug = new_status + ENDIF +!--------------------- +END SUBROUTINE ipsldbg +!=== +!------------------- +END MODULE errioipsl diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/flincom.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/flincom.f90 new file mode 100644 index 0000000..e53a386 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/flincom.f90 @@ -0,0 +1,1939 @@ +MODULE flincom +!- +!$Id: flincom.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- + USE netcdf +!- + USE calendar, ONLY : ju2ymds, ymds2ju, ioconf_calendar + USE errioipsl, ONLY : histerr + USE stringop, ONLY : strlowercase +!- + IMPLICIT NONE +!- + PRIVATE + PUBLIC :: flinput, flincre, flinget, flinclo, & + flinopen, flininfo, flininspect, flinquery_var +!- + INTERFACE flinopen +!--------------------------------------------------------------------- +!- The "flinopen" routines will open an input file +!- +!- INPUT +!- +!- filename : Name of the netCDF file to be opened +!- +!- iideb : index i for zoom ! +!- iilen : length of zoom ! for +!- jjdeb : index j for zoom ! zoom +!- jjlen : length of zoom ! +!- +!- do_test : A flag that enables the testing of the content +!- of the file against the input from the model +!- +!- INPUT if do_test=TRUE OUTPUT else +!- +!- iim : size in the x direction in the file (longitude) +!- jjm : size in the y direction +!- llm : number of levels +!- (llm = 0 means no axis to be expected) +!- lon : array of (iilen,jjlen) (zoom), or (iim,jjm) (no zoom), +!- that contains the longitude of each point +!- lat : same for latitude +!- lev : An array of llm for the latitude +!- +!- WARNING : +!- In the case of do_test=FALSE it is for the user to check +!- that the dimensions of lon lat and lev are correct when passed to +!- flinopen. This can be done after the call when iim and jjm have +!- been retrieved from the netCDF file. In F90 this problem will +!- be solved with an internal assign +!- IF iim, jjm, llm or ttm are parameters in the calling program and +!- you use the option do_test=FALSE it will create a segmentation fault +!- +!- OUTPUT +!- +!- ttm : size of time axis +!- itaus : Time steps within this file +!- date0 : Julian date at which itau = 0 +!- dt : length of the time steps of the data +!- fid : returned file ID which is later used to read the data +!--------------------------------------------------------------------- + MODULE PROCEDURE flinopen_zoom2d, flinopen_nozoom + END INTERFACE +!- + INTERFACE flinput +!--------------------------------------------------------------------- +!- The "flinput" routines will put a variable +!- on the netCDF file created by flincre. +!- If the sizes of the axis do not match the one of the IDs +!- then a new axis is created. +!- That is we loose the possibility of writting hyperslabs of data. +!- +!- Again here if iim = jjm = llm = ttm = 0 +!- then a global attribute is added to the file. +!- +!- INPUT +!- +!- fid : Identification of the file in which we will write +!- varname : Name of variable to be written +!- iim : size in x of variable +!- nlonid : ID of x axis which could fit for this axis +!- jjm : size in y of variable +!- nlatid : ID of y axis which could fit for this axis +!- llm : size in z of variable +!- zdimid : ID of z axis which could fit for this axis +!- ttm : size in t of variable +!- tdimid : ID of t axis which could fit for this axis +!- +!- OUTPUT +!- +!- NONE +!--------------------------------------------------------------------- + MODULE PROCEDURE flinput_r4d, flinput_r3d, flinput_r2d, & + flinput_r1d, flinput_scal + END INTERFACE +!- + INTERFACE flinget + MODULE PROCEDURE flinget_r4d, flinget_r3d, flinget_r2d, & + flinget_r1d, flinget_scal, & + flinget_r4d_zoom2d, flinget_r3d_zoom2d, & + flinget_r2d_zoom2d + END INTERFACE +!- +! This is the data we keep on each file we open +!- + INTEGER, PARAMETER :: nbfile_max = 200 + INTEGER, SAVE :: nbfiles = 0 + INTEGER, SAVE :: ncids(nbfile_max), ncnbd(nbfile_max), & + ncfunli(nbfile_max), ncnba(nbfile_max) + INTEGER, SAVE :: ncnbva(nbfile_max), ncdims(nbfile_max,4) + LOGICAL, SAVE :: ncfileopen(nbfile_max)=.FALSE. +!- + INTEGER, SAVE :: cind_vid, cind_fid, cind_len + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: cindex +!- + INTEGER,DIMENSION(4) :: w_sta, w_len, w_dim +!- +CONTAINS +!- +!=== +!- +SUBROUTINE flincre & + (filename, iim1, jjm1, lon1, lat1, llm1, lev1, ttm1, itaus, & + time0, dt, fid_out, nlonid1, nlatid1, zdimid1, tdimid1) +!--------------------------------------------------------------------- +!- This is a "low level" subroutine for opening netCDF files wich +!- contain the major coordinate system of the model. +!- Other coordinates needed for other variables +!- will be added as they are needed. +!- +!- INPUT +!- +!- filename : Name of the file to be created +!- iim1, jjm1 : Horizontal size of the grid +!- which will be stored in the file +!- lon1, lat1 : Horizontal grids +!- llm1 : Size of the vertical grid +!- lev1 : Vertical grid +!- ttm1 : Size of time axis +!- itaus : time steps on the time axis +!- time0 : Time in julian days at which itau = 0 +!- dt : time step in seconds between itaus +!- (one step of itau) +!- +!- OUTPUT +!- +!- fid : File identification +!- nlonid1 : Identification of longitudinal axis +!- nlatid1 : Identification of latitudinal axis +!- zdimid1 : ID of vertical axis +!- tdimid1 : ID of time axis +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + INTEGER :: iim1, jjm1, llm1, ttm1 + REAL :: lon1(iim1,jjm1) + REAL :: lat1(iim1,jjm1) + REAL :: lev1(llm1) + INTEGER :: itaus(ttm1) + REAL :: time0 + REAL :: dt + INTEGER :: fid_out, zdimid1, nlonid1, nlatid1, tdimid1 +!- +! LOCAL +!- + INTEGER :: iret, lll, fid + INTEGER :: lonid, latid, levid, timeid + INTEGER :: year, month, day + REAL :: sec + CHARACTER(LEN=250):: name +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + lll = LEN_TRIM(filename) + IF (filename(lll-2:lll) /= '.nc') THEN + name=filename(1:lll)//'.nc' + ELSE + name=filename(1:lll) + ENDIF +!- + iret = NF90_CREATE (name, NF90_CLOBBER, fid) +!- + iret = NF90_DEF_DIM (fid, 'x', iim1, nlonid1) + iret = NF90_DEF_DIM (fid, 'y', jjm1, nlatid1) + iret = NF90_DEF_DIM (fid, 'lev', llm1, zdimid1) + iret = NF90_DEF_DIM (fid, 'tstep', ttm1, tdimid1) +!- +! Vertical axis +!- + IF (check) WRITE(*,*) 'flincre Vertical axis' +!- + iret = NF90_DEF_VAR (fid, 'lev', NF90_FLOAT, zdimid1, levid) + iret = NF90_PUT_ATT (fid, levid, 'units', '-') + iret = NF90_PUT_ATT (fid, levid, 'title', 'levels') + iret = NF90_PUT_ATT (fid, levid, 'long_name', 'Sigma Levels') +!- +! Time axis +!- + IF (check) WRITE(*,*) 'flincre time axis' +!- + iret = NF90_DEF_VAR (fid, 'tstep', NF90_FLOAT, tdimid1, timeid) + iret = NF90_PUT_ATT (fid, timeid, 'units', '-') + iret = NF90_PUT_ATT (fid, timeid, 'title', 'time') + iret = NF90_PUT_ATT (fid, timeid, 'long_name', 'time steps') +!- +! The longitude +!- + IF (check) WRITE(*,*) 'flincre Longitude axis' +!- + iret = NF90_DEF_VAR (fid, "nav_lon", NF90_FLOAT, & + (/ nlonid1, nlatid1 /), lonid) + iret = NF90_PUT_ATT (fid, lonid, 'units', "degrees_east") + iret = NF90_PUT_ATT (fid, lonid, 'title', "Longitude") + iret = NF90_PUT_ATT (fid, lonid, 'nav_model', & + "Lambert projection of PROMES") + iret = NF90_PUT_ATT (fid, lonid, 'valid_min', & + REAL(MINVAL(lon1),KIND=4)) + iret = NF90_PUT_ATT (fid, lonid, 'valid_max', & + REAL(MAXVAL(lon1),KIND=4)) +!- +! The Latitude +!- + IF (check) WRITE(*,*) 'flincre Latitude axis' +!- + iret = NF90_DEF_VAR (fid, "nav_lat", NF90_FLOAT, & + (/ nlonid1, nlatid1 /), latid) + iret = NF90_PUT_ATT (fid, latid, 'units', "degrees_north") + iret = NF90_PUT_ATT (fid, latid, 'title', "Latitude") + iret = NF90_PUT_ATT (fid, latid, 'nav_model', & + "Lambert projection of PROMES") + iret = NF90_PUT_ATT (fid, latid, 'valid_min', & + REAL(MINVAL(lat1),KIND=4)) + iret = NF90_PUT_ATT (fid, latid, 'valid_max', & + REAL(MAXVAL(lat1),KIND=4)) +!- +! The time coordinates +!- + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', & + REAL(dt,KIND=4)) +!- + CALL ju2ymds (time0, year, month, day, sec) +!- + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'year0', REAL(year,KIND=4)) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'month0', REAL(month,KIND=4)) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'day0', REAL(day,KIND=4)) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'sec0', REAL(sec,KIND=4)) +!- + iret = NF90_ENDDEF (fid) +!- + IF (check) WRITE(*,*) 'flincre Variable' +!- + iret = NF90_PUT_VAR (fid, levid, lev1(1:llm1)) +!- + IF (check) WRITE(*,*) 'flincre Time Variable' +!- + iret = NF90_PUT_VAR (fid, timeid, REAL(itaus(1:ttm1))) +!- + IF (check) WRITE(*,*) 'flincre Longitude' +!- + iret = NF90_PUT_VAR (fid, lonid, lon1(1:iim1,1:jjm1)) +!- + IF (check) WRITE(*,*) 'flincre Latitude' +!- + iret = NF90_PUT_VAR (fid, latid, lat1(1:iim1,1:jjm1)) +!- +! Keep all this information +!- + nbfiles = nbfiles+1 +!- + IF (nbfiles > nbfile_max) THEN + CALL histerr (3,'flincre', & + 'Too many files. Please increase nbfil_max', & + 'in program flincom.F90.',' ') + ENDIF +!- + ncids(nbfiles) = fid + ncnbd(nbfiles) = 4 +!- + ncdims(nbfiles,1:4) = (/ iim1, jjm1, llm1, ttm1 /) +!- + ncfunli(nbfiles) = -1 + ncnba(nbfiles) = 4 + ncnbva(nbfiles) = 0 + ncfileopen(nbfiles) = .TRUE. +!- + fid_out = nbfiles +!--------------------- +END SUBROUTINE flincre +!- +!=== +!- +SUBROUTINE flinopen_zoom2d & + (filename, iideb, iilen, jjdeb, jjlen, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + LOGICAL :: do_test + INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen + REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm) + INTEGER :: itaus(ttm) + REAL :: date0, dt + INTEGER :: fid_out +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE (*,*) ' iideb, iilen, jjdeb, jjlen, iim, jjm ', & + iideb, iilen, jjdeb, jjlen, iim, jjm + IF (check) WRITE (*,*) ' lon ', lon(1,1), lon(iilen,jjlen) + IF (check) WRITE (*,*) ' lat ', lat(1,1), lat(iilen,jjlen) +!- + CALL flinopen_work & + (filename, iideb, iilen, jjdeb, jjlen, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!----------------------------- +END SUBROUTINE flinopen_zoom2d +!- +!=== +!- +SUBROUTINE flinopen_nozoom & + (filename, do_test, iim, jjm, llm, lon, lat, lev, ttm, & + itaus, date0, dt, fid_out) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + LOGICAL :: do_test + INTEGER :: iim, jjm, llm, ttm + REAL :: lon(iim,jjm), lat(iim,jjm), lev(llm) + INTEGER :: itaus(ttm) + REAL :: date0, dt + INTEGER :: fid_out +!--------------------------------------------------------------------- + CALL flinopen_work & + (filename, 1, iim, 1, jjm, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!------------------------- +END SUBROUTINE flinopen_nozoom +!- +!=== +!- +SUBROUTINE flinopen_work & + (filename, iideb, iilen, jjdeb, jjlen, do_test, & + iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + LOGICAL :: do_test + INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen + REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm) + INTEGER :: itaus(ttm) + REAL :: date0, dt + INTEGER :: fid_out +!- +! LOCAL +!- + REAL, PARAMETER :: eps = 1.e-4 +!- + INTEGER :: iret, vid, fid, nbdim, i, iilast, jjlast + INTEGER :: gdtt_id, old_id, iv, gdtmaf_id + CHARACTER(LEN=250) :: name + CHARACTER(LEN=80) :: units, calendar + INTEGER :: tmp_iim, tmp_jjm, tmp_llm, tmp_ttm + REAL :: x_first, x_last + INTEGER :: year, month, day + REAL :: r_year, r_month, r_day + INTEGER :: year0, month0, day0, hours0, minutes0, seci + REAL :: sec, sec0 + CHARACTER :: strc +!- + REAL,DIMENSION(:),ALLOCATABLE :: vec_tmp +!- + LOGICAL :: open_file + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + iilast = iideb+iilen-1 + jjlast = jjdeb+jjlen-1 + IF (check) WRITE (*,*) & + ' flinopen_work zoom 2D information '// & + ' iideb, iilen, iilast, jjdeb, jjlen, jjlast ', & + iideb, iilen, iilast, jjdeb, jjlen, jjlast +!- +! 1.0 get all infos on the file +!- +! Either the fid_out has not been initialized (0 or very large) +! then we have to open anyway. Else we only need to open the file +! if it has not been opened before. +!- + IF ( (fid_out < 1).OR.(fid_out > nbfile_max) ) THEN + open_file = .TRUE. + ELSE IF (.NOT.ncfileopen(fid_out)) THEN + open_file = .TRUE. + ELSE + open_file = .FALSE. + ENDIF +!- + IF (open_file) THEN + CALL flininfo (filename,tmp_iim,tmp_jjm,tmp_llm,tmp_ttm,fid_out) + ELSE +!-- The user has already opened the file +!-- and we trust that he knows the dimensions + tmp_iim = iim + tmp_jjm = jjm + tmp_llm = llm + tmp_ttm = ttm + ENDIF +!- + IF (check) & + WRITE(*,*) 'OUT OF flininfo :',tmp_iim,tmp_jjm,tmp_llm,tmp_ttm +!- + fid = ncids(fid_out) +!- +! 2.0 get the sizes and names of the different coordinates +! and do a first set of verification. +!- +! 2.2 We test the axis if we have to. +!- + IF (check) & + WRITE(*,*) 'flininfo 2.2 We test if we have to test : ',do_test +!- + IF (do_test) THEN + IF (iim /= tmp_iim) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' does not have the ', & + 'required dimension in x direction (longitude)',' ') + ELSE IF (jjm /= tmp_jjm) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' does not have the ', & + 'required dimension in y direction (latitude)',' ') + ELSE IF ( llm /= tmp_llm .AND. llm > 0 ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' does not have the ', & + 'required dimension in the vertical',' ') + ENDIF + ELSE +!--- +!-- 2.3 Else the sizes of the axes are returned to the user +!--- + IF (check) WRITE(*,*) 'flinopen 2.3 Else sizes are returned' +!--- + iim = tmp_iim + jjm = tmp_jjm + llm = tmp_llm + ENDIF +!- + ttm = tmp_ttm +!- +! 3.0 Check if we are realy talking about the same coodinate system +! if not then we get the lon, lat and lev variables from the file +!- + IF (check) WRITE(*,*) 'flinopen 3.0 we are realy talking' +!- + IF (do_test) THEN +!--- + CALL flinfindcood (fid_out, 'lon', vid, nbdim) + iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /)) + iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /)) +!--- + IF (check) & + WRITE(*,*) 'from file lon first and last, modulo 360. ', & + x_first, x_last, MODULO(x_first,360.), MODULO(x_last,360.) + IF (check) & + WRITE(*,*) 'from model lon first and last, modulo 360. ', & + lon(1,1),lon(iilen,jjlen), & + MODULO(lon(1,1),360.), MODULO(lon(iilen,jjlen),360.) + IF ( (ABS( MODULO(x_first,360.) & + -MODULO(lon(1,1),360.)) > eps) & + .OR.(ABS( MODULO(x_last,360.) & + -MODULO(lon(iilen ,jjlen),360.)) > eps ) ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' and the model do not', & + 'share the same longitude coordinate', & + 'Obtained by comparing the first and last values ') + ENDIF +!--- + CALL flinfindcood (fid_out, 'lat', vid, nbdim) + iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /)) + iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /)) +!--- + IF (check) WRITE(*,*) & + 'from file lat first and last ',x_first,x_last + IF (check) WRITE(*,*) & + 'from model lat first and last ',lat(1,1),lat(iilen,jjlen) +!--- + IF ( (ABS(x_first-lat(1,1)) > eps) & + .OR.(ABS(x_last-lat(iilen,jjlen)) > eps) ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' and the model do not', & + 'share the same latitude coordinate', & + 'Obtained by comparing the first and last values ') + ENDIF +!--- + IF (llm > 0) THEN + CALL flinfindcood (fid_out, 'lev', vid, nbdim) + iret = NF90_GET_VAR (fid, vid, x_first, start=(/ 1 /)) + iret = NF90_GET_VAR (fid, vid, x_last, start=(/ llm /)) +!----- + IF (check) WRITE(*,*) & + 'from file lev first and last ',x_first ,x_last + IF (check) WRITE(*,*) & + 'from model lev first and last ',lev(1),lev(llm) +!----- + IF ( (ABS(x_first-lev(1)) > eps) & + .OR.(ABS(x_last-lev(llm)) > eps) ) THEN + CALL histerr (3,'flinopen', & + 'file '//filename//' and the model do not', & + 'share the same vertical coordinate', & + 'Obtained by comparing the first and last values') + ENDIF + ENDIF +!--- + ELSE +!--- +!-- 4.0 extracting the coordinates if we do not check +!--- + IF (check) WRITE(*,*) 'flinopen 4.0 extracting the coordinates' +!--- + CALL flinfindcood (fid_out, 'lon', vid, nbdim) + IF (nbdim == 2) THEN + iret = NF90_GET_VAR (fid, vid, lon, & + start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /)) + ELSE + ALLOCATE(vec_tmp(iilen)) + iret = NF90_GET_VAR (fid, vid, vec_tmp, & + start=(/ iideb /), count=(/ iilen /)) + DO i=1,jjlen + lon(:,i) = vec_tmp(:) + ENDDO + DEALLOCATE(vec_tmp) + ENDIF +!--- + CALL flinfindcood (fid_out, 'lat', vid, nbdim) + IF (nbdim == 2) THEN + iret = NF90_GET_VAR (fid, vid, lat, & + start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /)) + ELSE + ALLOCATE(vec_tmp(jjlen)) + iret = NF90_GET_VAR (fid, vid, vec_tmp, & + start=(/ jjdeb /), count=(/ jjlen /)) + DO i=1,iilen + lat(i,:) = vec_tmp(:) + ENDDO + DEALLOCATE(vec_tmp) + ENDIF +!--- + IF (llm > 0) THEN + CALL flinfindcood (fid_out, 'lev', vid, nbdim) + IF (nbdim == 1) THEN + iret = NF90_GET_VAR (fid, vid, lev, & + start=(/ 1 /), count=(/ llm /)) + ELSE + CALL histerr (3,'flinopen', & + 'Can not handle vertical coordinates that have more',& + 'than 1 dimension',' ') + ENDIF + ENDIF + ENDIF +!- +! 5.0 Get all the details for the time if possible needed +!- + IF (check) WRITE(*,*) 'flinopen 5.0 Get time' +!- + IF (ttm > 0) THEN +!--- +!-- 5.1 Find the time axis. Prefered method is the 'timestep since' +!--- + gdtmaf_id = -1 + gdtt_id = -1 + old_id = -1 + DO iv=1,ncnbva(fid_out) + name='' + iret = NF90_INQUIRE_VARIABLE (fid, iv, name=name) + units='' + iret = NF90_GET_ATT (fid, iv, 'units', units) + IF (INDEX(units,'seconds since') > 0) gdtmaf_id = iv + IF (INDEX(units,'timesteps since') > 0) gdtt_id = iv + IF (INDEX(name, 'tstep') > 0) old_id = iv + ENDDO +!--- + IF (gdtt_id > 0) THEN + vid = gdtt_id + ELSE IF (gdtmaf_id > 0) THEN + vid = gdtmaf_id + ELSE IF (old_id > 0) THEN + vid = old_id + ELSE + CALL histerr (3, 'flinopen', 'No time axis found',' ',' ') + ENDIF +!--- + ALLOCATE(vec_tmp(ttm)) + iret = NF90_GET_VAR (fid,vid,vec_tmp,start=(/ 1 /),count=(/ ttm /)) + itaus(1:ttm) = NINT(vec_tmp(1:ttm)) + DEALLOCATE(vec_tmp) +!--- + IF (check) WRITE(*,*) 'flinopen 5.1 Times ',itaus +!--- +!-- Getting all the details for the time axis +!--- +!-- Find the calendar + calendar = '' + iret = NF90_GET_ATT (fid,gdtmaf_id,'calendar',calendar) + IF (iret == NF90_NOERR) THEN + CALL ioconf_calendar(calendar) + ENDIF +!-- + units = '' + iret = NF90_GET_ATT (fid,vid,'units',units) + IF (gdtt_id > 0) THEN + units = units(INDEX(units,'since')+6:LEN_TRIM(units)) + READ (units,'(I4.4,5(a,I2.2))') & + year0, strc, month0, strc, day0, & + strc, hours0, strc, minutes0, strc, seci + sec0 = hours0*3600. + minutes0*60. + seci + CALL ymds2ju (year0, month0, day0, sec0, date0) + IF (check) & + WRITE(*,*) 'flinopen 5.1 gdtt_id year0 ... date0 ', & + year0, month0, day0, sec0, date0 +!----- + iret = NF90_GET_ATT (fid, gdtt_id, 'tstep_sec', dt) + ELSE IF (gdtmaf_id > 0) THEN + units = units(INDEX(units,'since')+6:LEN_TRIM(units)) + READ (units,'(I4.4,5(a,I2.2))') & + year0, strc, month0, strc, day0, & + strc, hours0, strc, minutes0, strc, seci + sec0 = hours0*3600. + minutes0*60. + seci + CALL ymds2ju (year0, month0, day0, sec0, date0) +!----- + IF (check) & + WRITE(*,*) 'flinopen 5.1 gdtmaf_id year0 ... date0 ', & + year0, month0, day0, sec0, date0 + ELSE IF (old_id > 0) THEN + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', dt) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'day0', r_day) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'sec0', sec) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'year0', r_year) + iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'month0', r_month) +!----- + day = INT(r_day) + month = INT(r_month) + year = INT(r_year) +!----- + CALL ymds2ju (year, month, day, sec, date0) + ENDIF + ENDIF +!- + IF (check) WRITE(*,*) 'flinopen 6.0 File opened', date0, dt +!--------------------------- +END SUBROUTINE flinopen_work +!- +!=== +!- +SUBROUTINE flininfo (filename, iim, jjm, llm, ttm, fid_out) +!--------------------------------------------------------------------- +!- This subroutine allows to get some information. +!- It is usualy done within flinopen but the user may want to call +!- it before in order to allocate the space needed to extract the +!- data from the file. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + CHARACTER(LEN=*) :: filename + INTEGER :: iim, jjm, llm, ttm, fid_out +!- +! LOCAL +!- + INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim + INTEGER :: iv, lll + INTEGER :: xid, yid, zid, tid + CHARACTER(LEN=80) :: name + CHARACTER(LEN=30) :: axname +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + lll = LEN_TRIM(filename) + IF (filename(lll-2:lll) /= '.nc') THEN + name = filename(1:lll)//'.nc' + ELSE + name = filename(1:lll) + ENDIF +!- + iret = NF90_OPEN (name, NF90_NOWRITE, fid) + IF (iret /= NF90_NOERR) THEN + CALL histerr(3, 'flininfo','Could not open file :',TRIM(name),' ') + ENDIF +!- + iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, & + nAttributes=nb_atts, unlimitedDimId=id_unlim) +!- + xid = -1; iim = 0; + yid = -1; jjm = 0; + zid = -1; llm = 0; + tid = -1; ttm = 0; +!- + DO iv=1,ndims +!--- + iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll) + CALL strlowercase (axname) + axname = ADJUSTL(axname) +!--- + IF (check) WRITE(*,*) & + 'flininfo - getting axname',iv,axname,lll +!--- + IF ( (INDEX(axname,'x') == 1) & + .OR.(INDEX(axname,'lon') == 1) ) THEN + xid = iv; iim = lll; + ELSE IF ( (INDEX(axname,'y') == 1) & + .OR.(INDEX(axname,'lat') == 1) ) THEN + yid = iv; jjm = lll; + ELSE IF ( (INDEX(axname,'lev') == 1) & + .OR.(INDEX(axname,'plev') == 1) & + .OR.(INDEX(axname,'z') == 1) & + .OR.(INDEX(axname,'depth') == 1) ) THEN + zid = iv; llm = lll; + ELSE IF ( (INDEX(axname,'tstep') == 1) & + .OR.(INDEX(axname,'time_counter') == 1) ) THEN +!---- For the time we certainly need to allow for other names + tid = iv; ttm = lll; + ELSE IF (ndims == 1) THEN +!---- Nothing was found and ndims=1 then we have a vector of data + xid = 1; iim = lll; + ENDIF +!--- + ENDDO +!- +! Keep all this information +!- + nbfiles = nbfiles+1 +!- + IF (nbfiles > nbfile_max) THEN + CALL histerr (3,'flininfo', & + 'Too many files. Please increase nbfil_max', & + 'in program flincom.F90.',' ') + ENDIF +!- + ncids(nbfiles) = fid + ncnbd(nbfiles) = ndims +!- + ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /) +!- + ncfunli(nbfiles) = id_unlim + ncnba(nbfiles) = nb_atts + ncnbva(nbfiles) = nvars + ncfileopen(nbfiles) = .TRUE. +!- + fid_out = nbfiles +!---------------------- +END SUBROUTINE flininfo +!- +!=== +!- +SUBROUTINE flinput_r1d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r1d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r1d +!- +!=== +!- +SUBROUTINE flinput_r2d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:,:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r2d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r2d +!- +!=== +!- +SUBROUTINE flinput_r3d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:,:,:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r3d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r3d +!- +!=== +!- +SUBROUTINE flinput_r4d & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var(:,:,:,:) +!- + INTEGER :: fid, ncvarid, ndim, iret + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) & + "flinput_r4d : SIZE(var) = ",SIZE(var) +!- + CALL flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, & + fid,ncvarid,ndim) +!- + iret = NF90_PUT_VAR (fid, ncvarid, var, & + start=w_sta(1:ndim), count=w_len(1:ndim)) +!------------------------- +END SUBROUTINE flinput_r4d +!- +!=== +!- +SUBROUTINE flinput_mat & + (fid_in,varname,iim,nlonid,jjm,nlatid, & + llm,zdimid,ttm,tdimid,fid,ncvarid,ndim) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + INTEGER :: fid, ncvarid, ndim +!- +! LOCAL +!- + INTEGER :: iret +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + w_sta(1:4) = (/ 1, 1, 1, 1 /) + w_len(1:2) = (/ iim, jjm /) + w_dim(1:2) = (/ nlonid, nlatid /) +!- + IF ( (llm > 0).AND.(ttm > 0) ) THEN + ndim = 4 + w_len(3:4) = (/ llm, ttm /) + w_dim(3:4) = (/ zdimid, tdimid /) + ELSE IF (llm > 0) THEN + ndim = 3 + w_dim(3) = zdimid + w_len(3) = llm + ELSE IF (ttm > 0) THEN + ndim = 3 + w_dim(3) = tdimid + w_len(3) = ttm + ELSE + ndim = 2 + ENDIF +!- + iret = NF90_REDEF (fid) + iret = NF90_DEF_VAR (fid,varname,NF90_FLOAT,w_dim(1:ndim),ncvarid) + iret = NF90_PUT_ATT (fid,ncvarid,'short_name',TRIM(varname)) + iret = NF90_ENDDEF (fid) +!-------------------------- +END SUBROUTINE flinput_mat +!- +!=== +!- +SUBROUTINE flinput_scal & + (fid_in, varname, iim, nlonid, jjm, nlatid, & + llm, zdimid, ttm, tdimid, var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid + REAL :: var +!- +! LOCAL +!- + INTEGER :: fid, iret +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + iret = NF90_REDEF (fid) + iret = NF90_PUT_ATT (fid, NF90_GLOBAL, varname, REAL(var,KIND=4)) + iret = NF90_ENDDEF (fid) +!--------------------------- +END SUBROUTINE flinput_scal +!- +!=== +!- +SUBROUTINE flinget_r1d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:) +!- + INTEGER :: jl, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r1d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r1d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji) = buff_tmp(jl) + ENDDO +!------------------------- +END SUBROUTINE flinget_r1d +!- +!=== +!- +SUBROUTINE flinget_r2d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:,:) +!- + INTEGER :: jl, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj) = buff_tmp(jl) + ENDDO + ENDDO +!------------------------- +END SUBROUTINE flinget_r2d +!- +!=== +!- +SUBROUTINE flinget_r2d_zoom2d & + (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen + REAL :: var(:,:) +!- + INTEGER :: jl, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r2d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp) +!- + jl=0 + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj) = buff_tmp(jl) + ENDDO + ENDDO +!-------------------------------- +END SUBROUTINE flinget_r2d_zoom2d +!- +!=== +!- +SUBROUTINE flinget_r3d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:,:,:) +!- + INTEGER :: jl, jk, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO +!------------------------- +END SUBROUTINE flinget_r3d +!- +!=== +!- +SUBROUTINE flinget_r3d_zoom2d & + (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen + REAL :: var(:,:,:) +!- + INTEGER :: jl, jk, jj, ji + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r3d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp) +!- + jl=0 + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO +!-------------------------------- +END SUBROUTINE flinget_r3d_zoom2d +!- +!=== +!- +SUBROUTINE flinget_r4d & + (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var(:,:,:,:) +!- + INTEGER :: jl, jk, jj, ji, jm + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,1,iim,1,jjm,buff_tmp) +!- + jl=0 + DO jm=1,SIZE(var,4) + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk,jm) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO + ENDDO +!------------------------- +END SUBROUTINE flinget_r4d +!- +!=== +!- +SUBROUTINE flinget_r4d_zoom2d & + (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen + REAL :: var(:,:,:,:) +!- + INTEGER :: jl, jk, jj, ji, jm + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (.NOT.ALLOCATED(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var) + ALLOCATE (buff_tmp(SIZE(var))) + ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN + IF (check) WRITE(*,*) & + "flinget_r4d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var) + DEALLOCATE (buff_tmp) + ALLOCATE (buff_tmp(SIZE(var))) + ENDIF +!- + CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, & + itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp) +!- + jl=0 + DO jm=1,SIZE(var,4) + DO jk=1,SIZE(var,3) + DO jj=1,SIZE(var,2) + DO ji=1,SIZE(var,1) + jl=jl+1 + var(ji,jj,jk,jm) = buff_tmp(jl) + ENDDO + ENDDO + ENDDO + ENDDO +!-------------------------------- +END SUBROUTINE flinget_r4d_zoom2d +!- +!=== +!- +SUBROUTINE flinget_mat & + (fid_in, varname, iim, jjm, llm, ttm, itau_dep, & + itau_fin, iideb, iilen, jjdeb, jjlen, var) +!--------------------------------------------------------------------- +!- This subroutine will read the variable named varname from +!- the file previously opened by flinopen and identified by fid +!- +!- It is checked that the dimensions of the variable to be read +!- correspond to what the user requested when he specified +!- iim, jjm and llm. The only exception which is allowed is +!- for compressed data where the horizontal grid is not expected +!- to be iim x jjm. +!- +!- If variable is of size zero a global attribute is read. +!- This global attribute will be of type real +!- +!- INPUT +!- +!- fid : File ID returned by flinopen +!- varname : Name of the variable to be read from the file +!- iim : | These three variables give the size of the variables +!- jjm : | to be read. It will be verified that the variables +!- llm : | fits in there. +!- ttm : | +!- itau_dep : Time step at which we will start to read +!- itau_fin : Time step until which we are going to read +!- For the moment this is done on indexes +!- but it should be in the physical space. +!- If there is no time-axis in the file then use a +!- itau_fin < itau_dep, this will tell flinget not to +!- expect a time-axis in the file. +!- iideb : index i for zoom +!- iilen : length of zoom +!- jjdeb : index j for zoom +!- jjlen : length of zoom +!- +!- OUTPUT +!- +!- var : array that will contain the data +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm + INTEGER :: itau_dep, itau_fin, iideb, iilen, jjdeb, jjlen + REAL :: var(:) +!- +! LOCAL +!- + INTEGER :: iret, fid + INTEGER :: vid, cvid, clen + CHARACTER(LEN=70) :: str1 + CHARACTER(LEN=250) :: att_n, tmp_n + CHARACTER(LEN=5) :: axs_l + INTEGER :: tmp_i + REAL,SAVE :: mis_v=0. + REAL :: tmp_r + INTEGER :: ndims, x_typ, nb_atts + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dimids + INTEGER :: i, nvars, i2d, cnd + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: var_tmp + LOGICAL :: uncompress = .FALSE. + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + IF (check) THEN + WRITE(*,*) & + 'flinget_mat : fid_in, fid, varname :', fid_in, fid, TRIM(varname) + WRITE(*,*) & + 'flinget_mat : iim, jjm, llm, ttm, itau_dep, itau_fin :', & + iim, jjm, llm, ttm, itau_dep, itau_fin + WRITE(*,*) & + 'flinget_mat : iideb, iilen, jjdeb, jjlen :', & + iideb, iilen, jjdeb, jjlen + ENDIF +!- + uncompress = .FALSE. +!- +! 1.0 We get first all the details on this variable from the file +!- + nvars = ncnbva(fid_in) +!- + vid = -1 + iret = NF90_INQ_VARID (fid, varname, vid) +!- + IF (vid < 0 .OR. iret /= NF90_NOERR) THEN + CALL histerr (3,'flinget', & + 'Variable '//TRIM(varname)//' not found in file',' ',' ') + ENDIF +!- + iret = NF90_INQUIRE_VARIABLE (fid, vid, & + ndims=ndims, dimids=dimids, nAtts=nb_atts) + IF (check) THEN + WRITE(*,*) & + 'flinget_mat : fid, vid :', fid, vid + WRITE(*,*) & + 'flinget_mat : ndims, dimids(1:ndims), nb_atts :', & + ndims, dimids(1:ndims), nb_atts + ENDIF +!- + w_dim(:) = 0 + DO i=1,ndims + iret = NF90_INQUIRE_DIMENSION (fid, dimids(i), len=w_dim(i)) + ENDDO + IF (check) WRITE(*,*) & + 'flinget_mat : w_dim :', w_dim(1:ndims) +!- + mis_v = 0.0; axs_l = ' '; +!- + IF (nb_atts > 0) THEN + IF (check) THEN + WRITE(*,*) 'flinget_mat : attributes for variable :' + ENDIF + ENDIF + DO i=1,nb_atts + iret = NF90_INQ_ATTNAME (fid, vid, i, att_n) + iret = NF90_INQUIRE_ATTRIBUTE (fid, vid, att_n, xtype=x_typ) + CALL strlowercase (att_n) + IF ( (x_typ == NF90_INT).OR.(x_typ == NF90_SHORT) & + .OR.(x_typ == NF90_BYTE) ) THEN + iret = NF90_GET_ATT (fid, vid, att_n, tmp_i) + IF (check) THEN + WRITE(*,*) ' ',TRIM(att_n),' : ',tmp_i + ENDIF + ELSE IF ( (x_typ == NF90_FLOAT).OR.(x_typ == NF90_DOUBLE) ) THEN + iret = NF90_GET_ATT (fid, vid, att_n, tmp_r) + IF (check) THEN + WRITE(*,*) ' ',TRIM(att_n),' : ',tmp_r + ENDIF + IF (index(att_n,'missing_value') > 0) THEN + mis_v = tmp_r + ENDIF + ELSE + tmp_n = '' + iret = NF90_GET_ATT (fid, vid, att_n, tmp_n) + IF (check) THEN + WRITE(*,*) ' ',TRIM(att_n),' : ',TRIM(tmp_n) + ENDIF + IF (index(att_n,'axis') > 0) THEN + axs_l = tmp_n + ENDIF + ENDIF + ENDDO +!? +!!!!!!!!!! We will need a verification on the type of the variable +!? +!- +! 2.0 The dimensions are analysed to determine what is to be read +!- +! 2.1 the longitudes +!- + IF ( w_dim(1) /= iim .OR. w_dim(2) /= jjm) THEN +!--- +!-- There is a possibility that we have to deal with a compressed axis ! +!--- + iret = NF90_INQUIRE_DIMENSION (fid, dimids(1), & + name=tmp_n, len=clen) + iret = NF90_INQ_VARID (fid, tmp_n, cvid) +!--- + IF (check) WRITE(*,*) & + 'Dimname, iret , NF90_NOERR : ',TRIM(tmp_n),iret,NF90_NOERR +!--- +!-- If we have an axis which has the same name +!-- as the dimension we can see if it is compressed +!--- +!-- TODO TODO for zoom2d +!--- + IF (iret == NF90_NOERR) THEN + iret = NF90_GET_ATT (fid, cvid, 'compress', str1) +!----- + IF (iret == NF90_NOERR) THEN + iret = NF90_INQUIRE_VARIABLE (fid,cvid,xtype=x_typ,ndims=cnd) +!------- + IF ( cnd /= 1 .AND. x_typ /= NF90_INT) THEN + CALL histerr (3,'flinget', & + 'Variable '//TRIM(tmp_n)//' can not be a compressed axis', & + 'Either it has too many dimensions'// & + ' or it is not of type integer', ' ') + ELSE +!--------- +!-------- Let us see if we already have that index table +!--------- + IF ( (cind_len /= clen).OR.(cind_vid /= cvid) & + .OR.(cind_fid /= fid) ) THEN + IF (ALLOCATED(cindex)) DEALLOCATE(cindex) + ALLOCATE(cindex(clen)) + cind_len = clen + cind_vid = cvid + cind_fid = fid + iret = NF90_GET_VAR (fid, cvid, cindex) + ENDIF +!--------- +!-------- In any case we need to set the slab of data to be read +!--------- + uncompress = .TRUE. + w_sta(1) = 1 + w_len(1) = clen + i2d = 1 + ENDIF + ELSE + str1 = 'The horizontal dimensions of '//varname + CALL histerr (3,'flinget',str1, & + 'is not compressed and does not'// & + ' correspond to the requested size',' ') + ENDIF + ELSE + IF (w_dim(1) /= iim) THEN + str1 = 'The longitude dimension of '//varname + CALL histerr (3,'flinget',str1, & + 'in the file is not equal to the dimension', & + 'that should be read') + ENDIF + IF (w_dim(2) /= jjm) THEN + str1 = 'The latitude dimension of '//varname + CALL histerr (3,'flinget',str1, & + 'in the file is not equal to the dimension', & + 'that should be read') + ENDIF + ENDIF + ELSE + w_sta(1:2) = (/ iideb, jjdeb /) + w_len(1:2) = (/ iilen, jjlen /) + i2d = 2 + ENDIF +!- +! 2.3 Now the difficult part, the 3rd dimension which can be +! time or levels. +!- +! Priority is given to the time axis if only three axes are present. +!- + IF (ndims > i2d) THEN +!--- +!-- 2.3.1 We have a vertical axis +!--- + IF (llm == 1 .AND. ndims == i2d+2 .OR. llm == w_dim(i2d+1)) THEN +!----- + IF (w_dim(i2d+1) /= llm) THEN + CALL histerr (3,'flinget', & + 'The vertical dimension of '//varname, & + 'in the file is not equal to the dimension', & + 'that should be read') + ELSE + w_sta(i2d+1) = 1 + IF (llm > 0) THEN + w_len(i2d+1) = llm + ELSE + w_len(i2d+1) = w_sta(i2d+1) + ENDIF + ENDIF +!----- + IF ((itau_fin-itau_dep) >= 0) THEN + IF (ndims /= i2d+2) THEN + CALL histerr (3,'flinget', & + 'You attempt to read a time slab', & + 'but there is no time axis on this variable', varname) + ELSE IF ((itau_fin - itau_dep) <= w_dim(i2d+2)) THEN + w_sta(i2d+2) = itau_dep + w_len(i2d+2) = itau_fin-itau_dep+1 + ELSE + CALL histerr (3,'flinget', & + 'The time step you try to read is not', & + 'in the file (1)', varname) + ENDIF + ELSE IF (ndims == i2d+2 .AND. w_dim(i2d+2) > 1) THEN + CALL histerr (3,'flinget', & + 'There is a time axis in the file but no', & + 'time step give in the call', varname) + ELSE + w_sta(i2d+2) = 1 + w_len(i2d+2) = 1 + ENDIF + ELSE +!----- +!---- 2.3.2 We do not have any vertical axis +!----- + IF (ndims == i2d+2) THEN + CALL histerr (3,'flinget', & + 'The file contains 4 dimensions', & + 'but only 3 are requestes for variable ', varname) + ENDIF + IF ((itau_fin-itau_dep) >= 0) THEN + IF (ndims == i2d+1) THEN + IF ((itau_fin-itau_dep) < w_dim(i2d+1) ) THEN + w_sta(i2d+1) = itau_dep + w_len(i2d+1) = itau_fin-itau_dep+1 + ELSE + CALL histerr (3,'flinget', & + 'The time step you try to read is not', & + 'in the file (2)', varname) + ENDIF + ELSE + CALL histerr (3,'flinget', & + 'From your input you sould have 3 dimensions', & + 'in the file but there are 4', varname) + ENDIF + ELSE + IF (ndims == i2d+1 .AND. w_dim(i2d+1) > 1) THEN + CALL histerr (3,'flinget', & + 'There is a time axis in the file but no', & + 'time step given in the call', varname) + ELSE + w_sta(i2d+1) = 1 + w_len(i2d+1) = 1 + ENDIF + ENDIF + ENDIF + ELSE +!--- +!-- 2.3.3 We do not have any vertical axis +!--- + w_sta(i2d+1:i2d+2) = (/ 0, 0 /) + w_len(i2d+1:i2d+2) = (/ 0, 0 /) + ENDIF +!- +! 3.0 Reading the data +!- + IF (check) WRITE(*,*) & + 'flinget_mat 3.0 : ', uncompress, w_sta, w_len +!--- + IF (uncompress) THEN +!--- + IF (ALLOCATED(var_tmp)) THEN + IF (SIZE(var_tmp) < clen) THEN + DEALLOCATE(var_tmp) + ALLOCATE(var_tmp(clen)) + ENDIF + ELSE + ALLOCATE(var_tmp(clen)) + ENDIF +!--- + iret = NF90_GET_VAR (fid, vid, var_tmp, & + start=w_sta(:), count=w_len(:)) +!--- + var(:) = mis_v + var(cindex(:)) = var_tmp(:) +!--- + ELSE + iret = NF90_GET_VAR (fid, vid, var, & + start=w_sta(:), count=w_len(:)) + ENDIF +!- + IF (check) WRITE(*,*) 'flinget_mat 3.1 : ',NF90_STRERROR (iret) +!-------------------------- +END SUBROUTINE flinget_mat +!- +!=== +!- +SUBROUTINE flinget_scal & + (fid_in, varname, iim, jjm, llm, ttm, itau_dep, itau_fin, var) +!--------------------------------------------------------------------- +!- This subroutine will read the variable named varname from +!- the file previously opened by flinopen and identified by fid +!- +!- If variable is of size zero a global attribute is read. This +!- global attribute will be of type real +!- +!- INPUT +!- +!- fid : File ID returned by flinopen +!- varname : Name of the variable to be read from the file +!- iim : | These three variables give the size of the variables +!- jjm : | to be read. It will be verified that the variables +!- llm : | fits in there. +!- ttm : | +!- itau_dep : Time step at which we will start to read +!- itau_fin : Time step until which we are going to read +!- For the moment this is done on indeces but it should be +!- in the physical space +!- If there is no time-axis in the file then use a +!- itau_fin < itau_dep, this will tell flinget not to +!- expect a time-axis in the file. +!- +!- OUTPUT +!- +!- var : scalar that will contain the data +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: fid_in + CHARACTER(LEN=*) :: varname + INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin + REAL :: var +!- +! LOCAL +!- + INTEGER :: iret, fid +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) THEN + WRITE (*,*) 'flinget_scal in file with id ',fid_in + ENDIF +!- + fid = ncids(fid_in) +!- +! 1.0 Reading a global attribute +!- + iret = NF90_GET_ATT (fid, NF90_GLOBAL, varname, var) +!--------------------------- +END SUBROUTINE flinget_scal +!- +!=== +!- +SUBROUTINE flinfindcood (fid_in, axtype, vid, ndim) +!--------------------------------------------------------------------- +!- This subroutine explores the file in order to find +!- the coordinate according to a number of rules +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: fid_in, vid, ndim + CHARACTER(LEN=3) :: axtype +!- +! LOCAL +!- + INTEGER :: iv, iret, dimnb + CHARACTER(LEN=40) :: dimname, dimuni1, dimuni2, dimuni3 + CHARACTER(LEN=80) :: str1 + LOGICAL :: found_rule = .FALSE. +!--------------------------------------------------------------------- + vid = -1 +!- +! Make sure all strings are invalid +!- + dimname = '?-?' + dimuni1 = '?-?' + dimuni2 = '?-?' + dimuni3 = '?-?' +!- +! First rule : we look for the correct units +! lon : east +! lat : north +! We make an exact check as it would be too easy to mistake +! some units by just comparing the substrings. +!- + SELECTCASE(axtype) + CASE ('lon') + dimuni1 = 'degree_e' + dimuni2 = 'degrees_e' + found_rule = .TRUE. + CASE('lat') + dimuni1 = 'degree_n' + dimuni2 = 'degrees_n' + found_rule = .TRUE. + CASE('lev') + dimuni1 = 'm' + dimuni2 = 'km' + dimuni3 = 'hpa' + found_rule = .TRUE. + CASE DEFAULT + found_rule = .FALSE. + END SELECT +!- + IF (found_rule) THEN + iv = 0 + DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) ) + iv = iv+1 + str1 = '' + iret = NF90_GET_ATT (ncids(fid_in), iv, 'units', str1) + IF (iret == NF90_NOERR) THEN + CALL strlowercase (str1) + IF ( (INDEX(str1, TRIM(dimuni1)) == 1) & + .OR.(INDEX(str1, TRIM(dimuni2)) == 1) & + .OR.(INDEX(str1, TRIM(dimuni3)) == 1) ) THEN + vid = iv + iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, ndims=ndim) + ENDIF + ENDIF + ENDDO + ENDIF +!- +! Second rule : we find specific names : +! lon : nav_lon +! lat : nav_lat +! Here we can check if we find the substring as the +! names are more specific. +!- + SELECTCASE(axtype) + CASE ('lon') + dimname = 'nav_lon lon longitude' + found_rule = .TRUE. + CASE('lat') + dimname = 'nav_lat lat latitude' + found_rule = .TRUE. + CASE('lev') + dimname = 'plev level depth deptht' + found_rule = .TRUE. + CASE DEFAULT + found_rule = .FALSE. + END SELECT +!- + IF (found_rule) THEN + iv = 0 + DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) ) + iv = iv+1 + str1='' + iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, & + name=str1, ndims=ndim) + IF (INDEX(dimname,TRIM(str1)) >= 1) THEN + vid = iv + ENDIF + ENDDO + ENDIF +!- +! Third rule : we find a variable with the same name as the dimension +! lon = 1 +! lat = 2 +! lev = 3 +!- + IF (vid < 0) THEN + SELECTCASE(axtype) + CASE ('lon') + dimnb = 1 + found_rule = .TRUE. + CASE('lat') + dimnb = 2 + found_rule = .TRUE. + CASE('lev') + dimnb = 3 + found_rule = .TRUE. + CASE DEFAULT + found_rule = .FALSE. + END SELECT +!--- + IF (found_rule) THEN + iret = NF90_INQUIRE_DIMENSION (ncids(fid_in), dimnb, name=dimname) + iv = 0 + DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) ) + iv = iv+1 + str1='' + iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, & + name=str1, ndims=ndim) + IF (INDEX(dimname,TRIM(str1)) == 1) THEN + vid = iv + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Stop the program if no coordinate was found +!- + IF (vid < 0) THEN + CALL histerr (3,'flinfindcood', & + 'No coordinate axis was found in the file', & + 'The data in this file can not be used', axtype) + ENDIF +!-------------------------- +END SUBROUTINE flinfindcood +!- +!=== +!- +SUBROUTINE flinclo (fid_in) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in +!- + INTEGER :: iret +!--------------------------------------------------------------------- + iret = NF90_CLOSE (ncids(fid_in)) + ncfileopen(fid_in) = .FALSE. +!--------------------- +END SUBROUTINE flinclo +!- +!=== +!- +SUBROUTINE flinquery_var(fid_in, varname, exists) +!--------------------------------------------------------------------- +!- Queries the existance of a variable in the file. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid_in + CHARACTER(LEN=*) varname + LOGICAL :: exists +!- + INTEGER :: iret, fid, vid +!--------------------------------------------------------------------- + fid = ncids(fid_in) + vid = -1 + iret = NF90_INQ_VARID (fid, varname, vid) +!- + exists = ( (vid >= 0).AND.(iret == NF90_NOERR) ) +!--------------------------- +END SUBROUTINE flinquery_var +!- +!=== +!- +SUBROUTINE flininspect (fid_in) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! fid : File id to inspect +!- + INTEGER :: fid_in +!- +!- LOCAL +!- + INTEGER :: iim, jjm, llm, ttm, fid_out + INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim + INTEGER :: iv, in, lll + INTEGER :: xid, yid, zid, tid + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid + CHARACTER(LEN=80) :: name + CHARACTER(LEN=30) :: axname +!--------------------------------------------------------------------- + fid = ncids(fid_in) +!- + iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, & + nAttributes=nb_atts, unlimitedDimId=id_unlim) +!- + WRITE (*,*) 'IOIPSL ID : ',fid_in + WRITE (*,*) 'NetCDF ID : ',fid + WRITE (*,*) 'Number of dimensions : ',ndims + WRITE (*,*) 'Number of variables : ',nvars + WRITE (*,*) 'Number of global attributes : ',nb_atts + WRITE (*,*) 'ID unlimited : ',id_unlim +!- + xid = -1; iim = 0; + yid = -1; jjm = 0; + zid = -1; llm = 0; + tid = -1; ttm = 0; +!- + DO iv=1,ndims +!--- + iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll) + CALL strlowercase (axname) + axname = ADJUSTL(axname) +!--- + WRITE (*,*) 'Dimension number : ',iv + WRITE (*,*) 'Dimension name : ',TRIM(axname) +!--- + IF ( (INDEX(axname,'x') == 1) & + .OR.(INDEX(axname,'lon') == 1)) THEN + xid = iv; iim = lll; + WRITE (*,*) 'Dimension X size : ',iim + ELSE IF ( (INDEX(axname,'y') == 1) & + .OR.(INDEX(axname,'lat') == 1)) THEN + yid = iv; jjm = lll; + WRITE (*,*) 'Dimension Y size : ',jjm + ELSE IF ( (INDEX(axname,'lev') == 1) & + .OR.(INDEX(axname,'plev') == 1) & + .OR.(INDEX(axname,'z') == 1) & + .OR.(INDEX(axname,'depth') == 1)) THEN + zid = iv; llm = lll; + WRITE (*,*) 'Dimension Z size : ',llm + ELSE IF ( (INDEX(axname,'tstep') == 1) & + .OR.(INDEX(axname,'time_counter') == 1)) THEN +!---- For the time we certainly need to allow for other names + tid = iv; ttm = lll; + ELSE IF (ndims == 1) THEN +!---- Nothing was found and ndims=1 then we have a vector of data + xid = 1; iim = lll; + ENDIF +!--- + ENDDO +!- +! Keep all this information +!- + nbfiles = nbfiles+1 +!- + IF (nbfiles > nbfile_max) THEN + CALL histerr(3,'flininspect', & + 'Too many files. Please increase nbfil_max', & + 'in program flincom.F90.',' ') + ENDIF +!- + ncids(nbfiles) = fid + ncnbd(nbfiles) = ndims +!- + ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /) +!- + ncfunli(nbfiles) = id_unlim + ncnba(nbfiles) = nb_atts + ncnbva(nbfiles) = nvars + ncfileopen(nbfiles) = .TRUE. +!- + fid_out = nbfiles +!- + DO in=1,nvars + iret = NF90_INQUIRE_VARIABLE (fid, in, & + name=name, ndims=ndims, dimids=idimid, nAtts=nb_atts) + WRITE (*,*) 'Variable number ------------ > ', in + WRITE (*,*) 'Variable name : ', TRIM(name) + WRITE (*,*) 'Number of dimensions : ', ndims + WRITE (*,*) 'Dimensions ID''s : ', idimid(1:ndims) + WRITE (*,*) 'Number of attributes : ', nb_atts + ENDDO +!------------------------- +END SUBROUTINE flininspect +!- +!=== +!- +END MODULE flincom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/fliocom.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/fliocom.f90 new file mode 100644 index 0000000..9639938 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/fliocom.f90 @@ -0,0 +1,5173 @@ +MODULE fliocom +!- +!$Id: fliocom.f90 2512 2010-12-23 15:27:09Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE netcdf +!- +USE defprec +USE calendar, ONLY : lock_calendar,ioget_calendar, & + & ioconf_calendar,ju2ymds,ymds2ju +USE errioipsl, ONLY : ipslerr,ipsldbg +USE stringop, ONLY : strlowercase,str_xfw +!- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: & + & fliocrfd, fliopstc, fliodefv, flioputv, flioputa, & + & flioopfd, flioinqf, flioinqn, fliogstc, & + & flioinqv, fliogetv, flioinqa, fliogeta, & + & fliorenv, fliorena, fliodela, fliocpya, & + & flioqstc, fliosync, flioclo, fliodmpf, & + & flio_dom_set, flio_dom_unset, & + & flio_dom_defset, flio_dom_defunset, flio_dom_definq, & + & flio_dom_file, flio_dom_att +!- +!!-------------------------------------------------------------------- +!! The following PUBLIC parameters (with "flio_" prefix) +!! are used in the module "fliocom" : +!! +!! flio_max_files : maximum number of simultaneously opened files +!! flio_max_dims : maximum number of dimensions for a file +!! flio_max_var_dims : maximum number of dimensions for a variable +!! +!! FLIO_DOM_NONE : "named constant" for no_domain identifier +!! FLIO_DOM_DEFAULT : "named constant" for default_domain identifier +!! +!! flio_i : standard INTEGER external type +!! flio_r : standard REAL external type +!! flio_c : CHARACTER external type +!! flio_i1 : INTEGER*1 external type +!! flio_i2 : INTEGER*2 external type +!! flio_i4 : INTEGER*4 external type +!! flio_r4 : REAL*4 external type +!! flio_r8 : REAL*8 external type +!!-------------------------------------------------------------------- + INTEGER,PARAMETER,PUBLIC :: & + & flio_max_files=100, flio_max_dims=10, flio_max_var_dims=5 + INTEGER,PARAMETER,PUBLIC :: & + & flio_i = -1, flio_r = -2, flio_c =nf90_char, & + & flio_i1=nf90_int1, flio_i2=nf90_int2, flio_i4=nf90_int4, & + & flio_r4=nf90_real4, flio_r8=nf90_real8 +!- + INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_NONE =-1 + INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_DEFAULT = 0 +!- +!!-------------------------------------------------------------------- +!! The "fliocrfd" routine creates a model file +!! which contains the dimensions needed. +!! +!! SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n) +!! +!! INPUT +!! +!! (C) f_n : Name of the file to be created +!! (C) f_d_n(:) : Array of (max nb_fd_mx) names of the dimensions +!! (I) f_d_l(:) : Array of (max nb_fd_mx) lengths of the dimensions +!! For an unlimited dimension, enter a length of -1. +!! Actually, only one unlimited dimension is supported. +!! +!! OUTPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional INPUT arguments +!! +!! (I) id_dom : Identifier of a domain defined by calling +!! "flio_dom_set". If this argument is present, +!! and not equal to FLIO_DOM_NONE, it will be +!! appended to the file name and +!! the attributes describing the related DOMAIN +!! will be put in the created file. +!! This argument can be equal to FLIO_DOM_DEFAULT +!! (see "flio_dom_defset"). +!! (C) mode : String of (case insensitive) blank-separated words +!! defining the mode used to create the file. +!! Supported keywords : REPLACE, 32, 64 +!! If this argument is present with the keyword "REPLACE", +!! the file will be created in mode "CLOBBER", +!! else the file will be created in mode "NOCLOBBER". +!! "32/64" defines the offset mode. +!! The default offset mode is 64 bits. +!! Keywords "NETCDF4" and "CLASSIC" are reserved +!! for future use. +!! +!! Optional OUTPUT arguments +!! +!! (C) c_f_n : Name of the created file. +!! This name can be different of "f_n", +!! if a suffix is added to the original name +!! (".nc" or "DOMAIN_identifier.nc"). +!! The length of "c_f_n" must be sufficient +!! to receive the created file name. +!! +!!- NOTES +!! +!! The names used to identify the spatio-temporal dimensions +!! (dimension associated to a coordinate variable) +!! are the following : +!! +!! Axis Names +!! +!! x 'x[...]' 'lon[...]' +!! y 'y[...]' 'lat[...]' +!! z 'z[...]' 'lev[...]' 'plev[...]' 'depth[...]' +!! t 't' 'time' 'tstep[...]' 'time_counter[...]' +!! +!! Please, apply these rules so that coordinates are +!! correctly defined. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliopstc" routine defines the major coordinates system +!! (spatio-temporal axis) of the model file (created by fliocrfd). +!! +!! SUBROUTINE fliopstc & +!! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & +!! & t_axis,t_init,t_step,t_calendar) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional INPUT arguments +!! +!! (R) x_axis(:) : longitudinal grids +!! (R) x_axis_2d(:,:) : longitudinal grids +!! (R) y_axis(:) : latitudinal grids +!! (R) y_axis_2d(:,:) : latitudinal grids +!! (R) z_axis(:) : vertical grid +!! (I) t_axis(:) : timesteps on the time axis +!! (R) t_init : date in julian days at the beginning +!! (R) t_step : timestep in seconds between t_axis steps +!! (C) t_calendar : calendar +!! +!! [x/y]_axis and [x/y]_axis_2d are mutually exclusive. +!! +!!- NOTES +!! +!! The variables corresponding to the spatio-temporal coordinates +!! are created according to the following characteristics : +!! +!!- Longitude axis x_axis / x_axis_2d +!! Variable name 'lon' / 'nav_lon' +!! Attributes Values +!! 'axis' "X" +!! 'standard_name' "longitude" +!! 'units' "degrees_east" +!! 'valid_min' MINVAL(x_axis/x_axis_2d) +!! 'valid_max' MAXVAL(x_axis/x_axis_2d) +!! +!!- Latitude axis y_axis / y_axis_2d +!! Variable name 'lat' / 'nav_lat' +!! Attributes Values +!! 'axis' "Y" +!! 'standard_name' "latitude" +!! 'units' "degrees_north" +!! 'valid_min' MINVAL(y_axis/y_axis_2d) +!! 'valid_max' MAXVAL(y_axis/y_axis_2d) +!! +!!- Vertical axis z_axis +!! Variable name 'lev' +!! Attributes Values +!! 'axis' "Z" +!! 'standard_name' "model_level_number" +!! 'units' "sigma_level" +!! 'long_name' "Sigma Levels" +!! 'valid_min' MINVAL(z_axis) +!! 'valid_max' MAXVAL(z_axis) +!! +!!- Time axis t_axis +!! Variable name 'time' +!! Attributes Values +!! 'axis' "T" +!! 'standard_name' "time" +!! 'long_name' "time steps" +!! ['calendar' user/default valued] +!! 'units' calculated +!! +!! If you are not satisfied, it is possible +!! to rename variables ("fliorenv") +!! or overload the values of attributes ("flioputa"). +!! Be careful : the new values you use must allow to read variables +!! as coordinates. +!! +!! The dimensions associated to the coordinates variables +!! are searched according to their names (see "fliocrfd") +!!-------------------------------------------------------------------- +!- +INTERFACE fliodefv +!!-------------------------------------------------------------------- +!! The "fliodefv" routines define a variable in a model file. +!! +!! SUBROUTINE fliodefv & +!! & (f_i,v_n,[v_d],v_t, & +!! & axis,standard_name,long_name,units, & +!! & valid_min,valid_max,fillvalue) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to be defined +!! (I) [v_d] : +!! "not present" +!! --> scalar variable +!! "array of one or several integers containing +!! the identifiers of the dimensions of the variable +!! (in the order specified to "fliocrfd" +!! or obtained from "flioopfd")" +!! --> multidimensioned variable +!! +!! Optional INPUT arguments +!! +!! (I) v_t : External type of the variable +!! "present" --> see flio_.. +!! "not present" --> type of standard real +!! (C) axis,standard_name,long_name,units : Attributes +!! (axis should be used only for coordinates) +!! (R) valid_min,valid_max,fillvalue : Attributes +!!-------------------------------------------------------------------- + MODULE PROCEDURE & + & fliodv_r0d,fliodv_rnd +END INTERFACE +!- +INTERFACE flioputv +!!-------------------------------------------------------------------- +!! The "flioputv" routines put a variable (defined by fliodefv) +!! in a model file. +!! +!! SUBROUTINE flioputv (f_i,v_n,v_v,start,count) +!! +!! INPUT +!! +!! (I) f_i : model file identifier +!! (C) v_n : name of the variable to be written +!! (R/I) v_v : scalar or array (up to flio_max_var_dims dimensions) +!! containing the (standard) real/integer values +!! +!! Optional INPUT arguments +!! +!! (I) start(:) : array of integers specifying the index +!! where the first data value will be written +!! (I) count(:) : array of integers specifying the number of +!! indices that will be written along each dimension +!! (not present if v_v is a scalar) +!!-------------------------------------------------------------------- +!?INTEGERS of KIND 1 are not supported on all computers + MODULE PROCEDURE & + & fliopv_i40,fliopv_i41,fliopv_i42,fliopv_i43,fliopv_i44,fliopv_i45, & + & fliopv_i20,fliopv_i21,fliopv_i22,fliopv_i23,fliopv_i24,fliopv_i25, & +!& fliopv_i10,fliopv_i11,fliopv_i12,fliopv_i13,fliopv_i14,fliopv_i15, & + & fliopv_r40,fliopv_r41,fliopv_r42,fliopv_r43,fliopv_r44,fliopv_r45, & + & fliopv_r80,fliopv_r81,fliopv_r82,fliopv_r83,fliopv_r84,fliopv_r85 +END INTERFACE +!- +INTERFACE flioputa +!!-------------------------------------------------------------------- +!! The "flioputa" routines put a value for an attribute +!! in a model file. +!! If this attribute does not exist, it will be created. +!! +!! SUBROUTINE flioputa (f_i,v_n,a_n,a_v) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! If this name is "?", the attribute will be global. +!! (C) a_n : Name of the attribute to be defined. +!! ( ) a_v : scalar or array of real (kind 4 or 8) or integer values, +!! or character string +!!-------------------------------------------------------------------- + MODULE PROCEDURE & + & fliopa_r4_0d,fliopa_r4_1d,fliopa_r8_0d,fliopa_r8_1d, & + & fliopa_i4_0d,fliopa_i4_1d,fliopa_tx_0d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "flioopfd" routine opens an existing model file, +!! and returns the dimensions used in the file and a file identifier. +!! This information can be used to allocate the space needed +!! to extract the data from the file. +!! +!! SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat) +!! +!! INPUT +!! +!! (C) f_n : Name of the file to be opened +!! +!! OUTPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional INPUT arguments +!! +!! (C) mode : Access mode to the file. +!! If this argument is present with the value "WRITE", +!! the file will be accessed in mode "READ-WRITE", +!! else the file will be accessed in mode "READ-ONLY". +!! +!! Optional OUTPUT arguments +!! +!! (I) nb_dim : number of dimensions +!! (I) nb_var : number of variables +!! (I) nb_gat : number of global attributes +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioinqf" routine returns information +!! about an opened model file given its identifier. +!! +!! SUBROUTINE flioinqf & +!! & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional OUTPUT arguments +!! +!! (I) nb_dim : number of dimensions +!! (I) nb_var : number of variables +!! (I) nb_gat : number of global attributes +!! (I) id_uld : identifier of the unlimited dimension (0 if none) +!! (I) id_dim(:) : identifiers of the dimensions +!! (I) ln_dim(:) : lengths of the dimensions +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioinqn" routine returns the names +!! of the entities encountered in an opened model file. +!! +!! SUBROUTINE flioinqn & +!! & (f_i,cn_dim,cn_var,cn_gat,cn_uld, & +!! & id_start,id_count,iv_start,iv_count,ia_start,ia_count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional OUTPUT arguments +!! +!! (C) cn_dim(:) : names of dimensions +!! (C) cn_var(:) : names of variables +!! (C) cn_gat(:) : names of global attributes +!! (C) cn_uld : names of the unlimited dimension +!! +!! Optional INPUT arguments +!! +!! (I) id_start,id_count,iv_start,iv_count,ia_start,ia_count +!! +!! The prefix ( id / iv / ia ) specifies +!! the (dimensions/variables/global attributes) entities +!! +!! The suffix "start" specify the index from which +!! the first name will be retrieved (1 by default) +!! +!! The suffix "count" specifies the number of names to be retrieved +!! (all by default) +!! +!! If a requested entity is not available, a "?" will be returned. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliogstc" routine extracts the major coordinates system +!! (spatio-temporal axis) of the model file (opened by flioopfd). +!! +!! SUBROUTINE fliogstc & +!! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & +!! & t_axis,t_init,t_step,t_calendar, & +!! & x_start,x_count,y_start,y_count, & +!! & z_start,z_count,t_start,t_count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! +!! Optional OUTPUT arguments +!! +!! (R) x_axis(:) : longitudinal grids +!! (R) x_axis_2d(:,:) : longitudinal grids +!! (R) y_axis(:) : latitudinal grids +!! (R) y_axis_2d(:,:) : latitudinal grids +!! (R) z_axis(:) : vertical grid +!! (I) t_axis(:) : timesteps on the time axis +!! (R) t_init : date in julian days at the beginning +!! (R) t_step : timestep in seconds between t_axis steps +!! (C) t_calendar : calendar attribute +!! (the value is "not found" if the attribute +!! is not present in the model file) +!! +!! [x/y]_axis and [x/y]_axis_2d are mutually exclusive. +!! +!! Optional INPUT arguments +!! +!! (I) x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count +!! +!! The prefix (x/y/z/t) specifies the concerned direction. +!! +!! The suffix "start" specify the index from which +!! the first data value will be read (1 by default) +!! +!! The suffix "count" specifies the number of values to be read +!! (all by default) +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioinqv" routine returns information about a model +!! variable given its name. +!! This information can be used to allocate the space needed +!! to extract the variable from the file. +!! +!! SUBROUTINE flioinqv & +!! & (f_i,v_n,l_ex,nb_dims,len_dims,id_dims, & +!! & nb_atts,cn_atts,ia_start,ia_count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of the variable +!! +!! OUTPUT +!! +!! (L) l_ex : Existence of the variable +!! +!! Optional OUTPUT arguments +!! +!! (I) v_t : External type of the variable (see flio_..) +!! (I) nb_dims : number of dimensions of the variable +!! (I) len_dims(:) : list of dimension lengths of the variable +!! (I) id_dims(:) : list of dimension identifiers of the variable +!! (I) nb_atts : number of attributes of the variable +!! (C) cn_atts(:) : names of the attributes +!! +!! Optional INPUT arguments +!! +!! (I) ia_start : index of the first attribute whose the name +!! will be retrieved (1 by default) +!! (I) ia_count : number of names to be retrieved (all by default) +!! +!! If a requested entity is not available, a "?" will be returned. +!!-------------------------------------------------------------------- +!- +INTERFACE fliogetv +!!-------------------------------------------------------------------- +!! The "fliogetv" routines get a variable from a model file. +!! +!! SUBROUTINE fliogetv (f_i,v_n,v_v,start,count) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of the variable to be read +!! +!! OUTPUT +!! +!! (R/I) v_v : scalar or array (up to flio_max_var_dims dimensions) +!! that will contain the (standard) real/integer values +!! +!! Optional INPUT arguments +!! +!! (I) start(:) : array of integers specifying the index +!! from which the first data value will be read +!! (I) count(:) : array of integers specifying the number of +!! indices that will be read along each dimension +!! (not present if v_v is a scalar) +!!-------------------------------------------------------------------- +!?INTEGERS of KIND 1 are not supported on all computers + MODULE PROCEDURE & + & fliogv_i40,fliogv_i41,fliogv_i42,fliogv_i43,fliogv_i44,fliogv_i45, & + & fliogv_i20,fliogv_i21,fliogv_i22,fliogv_i23,fliogv_i24,fliogv_i25, & +!& fliogv_i10,fliogv_i11,fliogv_i12,fliogv_i13,fliogv_i14,fliogv_i15, & + & fliogv_r40,fliogv_r41,fliogv_r42,fliogv_r43,fliogv_r44,fliogv_r45, & + & fliogv_r80,fliogv_r81,fliogv_r82,fliogv_r83,fliogv_r84,fliogv_r85 +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "flioinqa" routine returns information about an +!! attribute of a variable given their names, in a model file. +!! Information about a variable includes its existence, +!! and the number of values currently stored in the attribute. +!! For a string-valued attribute, this is the number of +!! characters in the string. +!! This information can be used to allocate the space needed +!! to extract the attribute from the file. +!! +!! SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the concerned attribute. +!! +!! OUTPUT +!! +!! (L) l_ex : existence of the variable +!! +!! Optional OUTPUT arguments +!! +!! (I) a_t : external type of the attribute +!! (I) a_l : number of values of the attribute +!!-------------------------------------------------------------------- +!- +INTERFACE fliogeta +!!-------------------------------------------------------------------- +!! The "fliogeta" routines get a value for an attribute +!! in a model file. +!! +!! SUBROUTINE fliogeta (f_i,v_n,a_n,a_v) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the attribute to be retrieved. +!! ( ) a_v : scalar or array of real (kind 4 or 8) or integer values, +!! or character string +!!-------------------------------------------------------------------- + MODULE PROCEDURE & + & flioga_r4_0d,flioga_r4_1d,flioga_r8_0d,flioga_r8_1d, & + & flioga_i4_0d,flioga_i4_1d,flioga_tx_0d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "fliorenv" routine renames a variable, in a model file. +!! +!! SUBROUTINE fliorenv (f_i,v_o_n,v_n_n) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_o_n : Old name of the variable +!! (C) v_n_n : New name of the variable +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliorena" routine renames an attribute +!! of a variable, in a model file. +!! +!! SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_o_n : Old name of the concerned attribute. +!! (C) a_n_n : New name of the concerned attribute. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliodela" routine deletes an attribute in a model file. +!! +!! SUBROUTINE fliodela (f_i,v_n,a_n) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) v_n : Name of variable to which the attribute is assigned. +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the concerned attribute. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliocpya" routine copies an attribute +!! from one open model file to another. +!! It can also be used to copy an attribute from +!! one variable to another within the same model file. +!! +!! SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o) +!! +!! INPUT +!! +!! (I) f_i_i : Identifier of the input model file +!! (C) v_n_i : Name of the input variable +!! This name is "?" for a global attribute. +!! (C) a_n : Name of the concerned attribute. +!! (I) f_i_o : Identifier of the output model file +!! It can be the same as the input identifier. +!! (C) v_n_o : Name of the output variable +!! This name is "?" for a global attribute. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioqstc" routine search for a spatio-temporal coordinate +!! in a model file and returns its name. +!! +!! SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name) +!! +!! INPUT +!! +!! (I) f_i : Model file identifier +!! (C) c_type : Type of the coordinate ("x"/"y"/"z"/"t") +!! +!! OUTPUT +!! +!! (L) l_ex : existence of the coordinate +!! (C) c_name : name of the coordinate +!! +!!- NOTES +!! +!! The following rules are used for searching variables +!! which are spatio-temporal coordinates (x/y/z/t). +!! +!!-- Rule 1 : we look for a variable with one dimension +!!-- and which has the same name as its dimension +!! +!!-- Rule 2 : we look for a correct "axis" attribute +!! +!! Axis Axis attribute Number of dimensions +!! (case insensitive) +!! +!! x X 1/2 +!! y Y 1/2 +!! z Z 1 +!! t T 1 +!! +!!-- Rule 3 : we look for a correct "standard_name" attribute +!! +!! Axis Axis attribute Number of dimensions +!! (case insensitive) +!! +!! x longitude 1/2 +!! y latitude 1/2 +!! z model_level_number 1 +!! t time 1 +!! +!!-- Rule 4 : we look for a specific name +!! +!! Axis Names +!! +!! x 'nav_lon' 'lon' 'longitude' +!! y 'nav_lat' 'lat' 'latitude' +!! z 'depth' 'deptht' 'height' 'level' +!! 'lev' 'plev' 'sigma_level' 'layer' +!! t 'time' 'tstep' 'timesteps' +!! +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliosync" routine synchronise one or all opened model files, +!! to minimize data loss in case of abnormal termination. +!! +!! SUBROUTINE fliosync (f_i) +!! +!! Optional INPUT arguments +!! +!! (I) f_i : Model file identifier +!! If this argument is not present, +!! all the opened model files are synchronised. +!--------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "flioclo" routine closes one or all opened model files +!! and frees the space needed to keep information about the files +!! +!! SUBROUTINE flioclo (f_i) +!! +!! Optional INPUT arguments +!! +!! (I) f_i : Model file identifier +!! If this argument is not present, +!! all the opened model files are closed. +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! The "fliodmpf" routine dumps a model file +!! and prints the result on the standard output. +!! +!! SUBROUTINE fliodmpf (f_n) +!! +!! INPUT +!! +!! (C) f_n : Name of the model file to be dumped +!!-------------------------------------------------------------------- +!- +!!-------------------------------------------------------------------- +!! This "flio_dom_set" sets up the domain activity of IOIPSL. +!! It stores all the domain information and allows it to be stored +!! in the model file and change the file names. +!! +!! This routine must be called by the user before opening +!! the model file. +!! +!! SUBROUTINE flio_dom_set & +!! & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom) +!! +!! INPUT +!! +!! (I) dtnb : total number of domains +!! (I) dnb : domain number +!! (I) did(:) : distributed dimensions identifiers +!! (up to 5 dimensions are supported) +!! (I) dsg(:) : total number of points for each dimension +!! (I) dsl(:) : local number of points for each dimension +!! (I) dpf(:) : position of first local point for each dimension +!! (I) dpl(:) : position of last local point for each dimension +!! (I) dhs(:) : start halo size for each dimension +!! (I) dhe(:) : end halo size for each dimension +!! (C) cdnm : Model domain definition name. +!! The names actually supported are : +!! "BOX", "APPLE", "ORANGE". +!! These names are case insensitive. +!! +!! OUTPUT argument +!! +!! (I) id_dom : Model domain identifier +!! +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_unset" routine unsets one or all set domains +!! and frees the space needed to keep information about the domains +!! +!! This routine should be called by the user to free useless domains. +!! +!! SUBROUTINE flio_dom_unset (id_dom) +!! +!! Optional INPUT arguments +!! +!! (I) id_dom : Model domain identifier +!! >=1 & <= dom_max_nb : the domain is closed +!! not present : all the set model domains are unset +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_defset" sets +!! the default domain identifier. +!! +!! SUBROUTINE flio_dom_defset (id_dom) +!! +!! INPUT argument +!! +!! (I) id_dom : Model default domain identifier +!! ( >=1 & <= dom_max_nb ) +!! This identifier will be able to be taken by calling +!! "flio_dom_definq" and used to create model files +!! with the corresponding domain definitions +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_defunset" routine unsets +!! the default domain identifier. +!! +!! SUBROUTINE flio_dom_defunset () +!! +!!-------------------------------------------------------------------- +!! +!!-------------------------------------------------------------------- +!! The "flio_dom_definq" routine inquires about +!! the default domain identifier. +!! You should call this procedure to safeguard the current +!! default domain identifier if you wish to use locally +!! another default domain, in order to restore it. +!! +!! SUBROUTINE flio_dom_definq (id_dom) +!! +!! OUTPUT argument +!! +!! (I) id_dom : Model default domain identifier +!! IF no default domain identifier has been set, +!! the returned value is "FLIO_DOM_NONE". +!!-------------------------------------------------------------------- +!- +!--------------------------------------------------------------------- +! This is the data we keep concerning each file we open +!--------------------------------------------------------------------- +!- For each file +!- (I) nw_id(f_i) : index to access at this file +!- (I) nw_nd(f_i) : number of dimensions +!- (I) nw_nv(f_i) : number of variables +!- (I) nw_na(f_i) : number of global attributes +!- (I) nw_un(f_i) : ID of the first unlimited dimension +!- (L) lw_hm(f_i) : for mode handling (.TRUE. define, .FALSE. data) +!- (I) nw_di(:,f_i) : dimension IDs in the file "f_i" +!- (I) nw_dl(:,f_i) : dimension lengths in the file "f_i" +!- (I) nw_ai(:,f_i) : dimension Ids for the axis in the file "f_i" +!--------------------------------------------------------------------- + INTEGER,PARAMETER :: & + & nb_fi_mx=flio_max_files, & + & nb_fd_mx=flio_max_dims, & + & nb_vd_mx=flio_max_var_dims + INTEGER,PARAMETER :: nb_ax_mx=4 +!- + INTEGER,PARAMETER :: k_lon=1, k_lat=2, k_lev=3, k_tim=4 +!- + INTEGER,DIMENSION(nb_fi_mx),SAVE :: & + & nw_id=-1,nw_nd,nw_nv,nw_na,nw_un + LOGICAL,DIMENSION(nb_fi_mx),SAVE :: lw_hm + INTEGER,DIMENSION(nb_fd_mx,nb_fi_mx),SAVE :: nw_di=-1,nw_dl=-1 + INTEGER,DIMENSION(nb_ax_mx,nb_fi_mx),SAVE :: nw_ai=-1 +!- +! Maximum number of simultaneously defined domains + INTEGER,PARAMETER :: dom_max_nb=200 +!- +! Maximum number of distributed dimensions for each domain + INTEGER,PARAMETER :: dom_max_dims=5 +!- +! Default domain identifier + INTEGER,SAVE :: id_def_dom=FLIO_DOM_NONE +!- +! Supported domain definition names + INTEGER,PARAMETER :: n_dns=3, l_dns=7 + CHARACTER(LEN=l_dns),DIMENSION(n_dns),SAVE :: & + & c_dns=(/ "box ","apple ","orange "/) +!- +! DOMAINS related variables + INTEGER,DIMENSION(1:dom_max_nb),SAVE :: & + & d_d_n=-1, d_n_t=0, d_n_c=0 + INTEGER,DIMENSION(1:dom_max_dims,1:dom_max_nb),SAVE :: & + & d_d_i, d_s_g, d_s_l, d_p_f, d_p_l, d_h_s, d_h_e + CHARACTER(LEN=l_dns),DIMENSION(1:dom_max_nb),SAVE :: c_d_t +!- +!=== +CONTAINS +!=== +!- +!--------------------------------------------------------------------- +!- Public procedures +!--------------------------------------------------------------------- +!- +!=== +SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: f_n + CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: f_d_n + INTEGER,DIMENSION(:),INTENT(IN) :: f_d_l + INTEGER,INTENT(OUT) :: f_i + INTEGER,OPTIONAL,INTENT(IN) :: id_dom + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: c_f_n +!- + INTEGER :: i_rc,f_e,idid,ii,m_c,n_u + CHARACTER(LEN=NF90_MAX_NAME) :: f_nw + INTEGER,PARAMETER :: l_string=80,l_word=10 + CHARACTER(LEN=l_string) :: c_string + CHARACTER(LEN=l_word) :: c_word + LOGICAL :: l_ok + INTEGER,PARAMETER :: k_replace=1 + INTEGER,PARAMETER :: k_32=1,k_64=2 +!- !? : Code to be activated for NETCDF4 +!? INTEGER,PARAMETER :: k_netcdf4=1,k_classic=1 + INTEGER,PARAMETER :: n_opt=4 + INTEGER,DIMENSION(n_opt) :: i_opt +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliocrfd - file name : ",TRIM(f_n) + ENDIF +!- +! Search for a free local identifier + f_i = flio_rid() + IF (f_i < 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Too many files.','Please increase nb_fi_mx', & + & 'in module fliocom.f90.') + ENDIF +!- +! Update the name of the file + f_nw = f_n + CALL flio_dom_file (f_nw,id_dom) +!- +! Check the dimensions + IF (SIZE(f_d_l) /= SIZE(f_d_n)) THEN + CALL ipslerr (3,'fliocrfd', & + & 'The number of names is not equal to the number of lengths', & + & 'for the dimensions of the file',TRIM(f_nw)) + ENDIF + IF (SIZE(f_d_l) > nb_fd_mx) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Too many dimensions','to create the file',TRIM(f_nw)) + ENDIF +!- +! Check the mode +!- + i_opt(:)=-1 +!- + IF (PRESENT(mode)) THEN +!--- + IF (LEN_TRIM(mode) > l_string) THEN + CALL ipslerr (3,'fliocrfd', & + & '"mode" argument','too long','to be treated') + ENDIF + c_string = mode(:) + CALL strlowercase (c_string) +!--- + DO + CALL str_xfw (c_string,c_word,l_ok) + IF (l_ok) THEN +!- !? : Code to be activated for NETCDF4 + SELECT CASE (TRIM(c_word)) + CASE('replace') + IF (i_opt(1) > 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Replace option','already','defined') + ELSE + i_opt(1) = k_replace + ENDIF +!? CASE('netcdf4') +!? IF (i_opt(2) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Netcdf4 format','already','defined') +!? ELSE +!? i_opt(2) = k_netcdf4 +!? ENDIF + CASE('32') + IF (i_opt(3) > 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Offset format','already','defined') + ELSE + i_opt(3) = k_32 + ENDIF + CASE('64') + IF (i_opt(3) > 0) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Offset format','already','defined') + ELSE + i_opt(3) = k_64 + ENDIF +!? CASE('CLASSIC') +!? IF (i_opt(4) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Netcdf4 classic format','already','defined') +!? ELSE +!? i_opt(4) = k_classic +!? ENDIF + CASE DEFAULT + CALL ipslerr (3,'fliocrfd', & + & 'Option '//TRIM(c_word),'not','supported') + END SELECT + ELSE + EXIT + ENDIF + ENDDO + ENDIF +!- + IF (i_opt(1) == k_replace) THEN + m_c = NF90_CLOBBER + ELSE + m_c = NF90_NOCLOBBER + ENDIF +!- +!- Code to be replaced by the following for NETCDF4 +!? IF (i_opt(2) == k_netcdf4) THEN +!? m_c = IOR(m_c,NF90_NETCDF4) +!? IF (i_opt(3) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Netcdf4 format','and offset option','are not compatible') +!? ELSE IF (i_opt(4) == k_classic) THEN +!? m_c = IOR(m_c,NF90_CLASSIC_MODEL) +!? ENDIF +!? LSE IF (i_opt(4) > 0) THEN +!? CALL ipslerr (3,'fliocrfd', & +!? & 'Classic option','is reserved','for the Netcdf4 format') +!? ELSE + IF (i_opt(3) /= k_32) THEN + m_c = IOR(m_c,NF90_64BIT_OFFSET) + ENDIF +!? ENDIF +!- +! Create file (and enter the definition mode) + i_rc = NF90_CREATE(f_nw,m_c,f_e) + lw_hm(f_i) = .TRUE. + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocrfd', & + & 'Could not create file :',TRIM(f_nw), & + & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) ' fliocrfd, external model file-id : ',f_e + ENDIF +!- +! Create dimensions + n_u = 0 + DO ii=1,SIZE(f_d_l) + IF (f_d_l(ii) == -1) THEN + IF (n_u == 0) THEN + i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),NF90_UNLIMITED,idid) + n_u = n_u+1 + ELSE + CALL ipslerr (3,'fliocrfd', & + & 'Can not handle more than one unlimited dimension', & + & 'for file :',TRIM(f_nw)) + ENDIF + ELSE IF (f_d_l(ii) > 0) THEN + i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),f_d_l(ii),idid) + ENDIF + IF ( ((f_d_l(ii) == -1).OR.(f_d_l(ii) > 0)) & + & .AND.(i_rc /= NF90_NOERR) ) THEN + CALL ipslerr (3,'fliocrfd', & + & 'One dimension can not be defined', & + & 'for the file :',TRIM(f_nw)) + ENDIF + ENDDO +!- +! Define "Conventions" global attribute + i_rc = NF90_PUT_ATT(f_e,NF90_GLOBAL,'Conventions',"CF-1.1") +!- +! Add the DOMAIN attributes if needed + CALL flio_dom_att (f_e,id_dom) +!- +! Keep the file information + nw_id(f_i) = f_e + CALL flio_inf (f_e, & + & nb_dims=nw_nd(f_i),id_unlm=nw_un(f_i),nb_atts=nw_na(f_i), & + & nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i)) +!- +! Return the created file name if needed + IF (PRESENT(c_f_n)) THEN + IF (LEN(c_f_n) >= LEN_TRIM(f_nw)) THEN + c_f_n = TRIM(f_nw) + ELSE + CALL ipslerr (3,'fliocrfd', & + & 'the length of "c_f_n" is not sufficient to receive', & + & 'the name of the created file :',TRIM(f_nw)) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) '<-fliocrfd' + ENDIF +!---------------------- +END SUBROUTINE fliocrfd +!=== +SUBROUTINE fliopstc & + & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & + & t_axis,t_init,t_step,t_calendar) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: x_axis,y_axis + REAL,DIMENSION(:,:),OPTIONAL,INTENT(IN) :: x_axis_2d,y_axis_2d + REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: z_axis + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: t_axis + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: t_calendar + REAL,OPTIONAL,INTENT(IN) :: t_init,t_step +!- + INTEGER :: i_rc,f_e + INTEGER :: lonid,latid,levid,timeid + INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss + REAL :: dt,r_ss,v_min,v_max + INTEGER :: k,k_1,k_2 + LOGICAL :: l_tmp + CHARACTER(LEN=20) :: c_tmp1 + CHARACTER(LEN=40) :: c_tmp2 + CHARACTER(LEN=80) :: c_tmp3 +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliopstc" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliopstc',f_i,f_e) +!- +! Validate the coherence of the arguments +!- + IF ( (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) & + & .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'The [x/y]_axis arguments', & + & 'are not coherent :',& + & 'can not handle two [x/y]_axis') + ENDIF +!- + IF ( PRESENT(x_axis).OR.PRESENT(x_axis_2d) & + & .OR.PRESENT(y_axis).OR.PRESENT(y_axis_2d) ) THEN + k_1=nw_ai(k_lon,f_i); k_2=nw_ai(k_lat,f_i); + ENDIF +!- +! Define the longitude axis +!- + IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Longitude axis' + ENDIF +!--- + IF (PRESENT(x_axis)) THEN + IF (SIZE(x_axis) /= nw_dl(k_1,f_i)) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid x_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF + ELSE + IF ( (SIZE(x_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) & + & .OR.(SIZE(x_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid x_axis_2d dimensions :', & + & 'not equal to the dimensions', & + & 'defined at the creation of the file') + ENDIF + ENDIF +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + IF (PRESENT(x_axis)) THEN + i_rc = NF90_DEF_VAR(f_e,"lon",NF90_REAL4, & + & nw_di(k_1,f_i),lonid) + v_min = MINVAL(x_axis) + v_max = MAXVAL(x_axis) + ELSE + i_rc = NF90_DEF_VAR(f_e,"nav_lon",NF90_REAL4, & + & nw_di((/k_1,k_2/),f_i),lonid) + v_min = MINVAL(x_axis_2d) + v_max = MAXVAL(x_axis_2d) + ENDIF + i_rc = NF90_PUT_ATT(f_e,lonid,"axis","X") + i_rc = NF90_PUT_ATT(f_e,lonid,'standard_name',"longitude") + i_rc = NF90_PUT_ATT(f_e,lonid,'units',"degrees_east") + i_rc = NF90_PUT_ATT(f_e,lonid,'valid_min',REAL(v_min,KIND=4)) + i_rc = NF90_PUT_ATT(f_e,lonid,'valid_max',REAL(v_max,KIND=4)) + ENDIF +!- +! Define the Latitude axis +!- + IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Latitude axis' + ENDIF +!--- + IF (PRESENT(y_axis)) THEN + IF (SIZE(y_axis) /= nw_dl(k_2,f_i)) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid y_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF + ELSE + IF ( (SIZE(y_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) & + & .OR.(SIZE(y_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid y_axis_2d dimensions :', & + & 'not equal to the dimensions', & + & 'defined at the creation of the file') + ENDIF + ENDIF +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + IF (PRESENT(y_axis)) THEN + i_rc = NF90_DEF_VAR(f_e,"lat",NF90_REAL4, & + & nw_di(k_2,f_i),latid) + v_min = MINVAL(y_axis) + v_max = MAXVAL(y_axis) + ELSE + i_rc = NF90_DEF_VAR(f_e,"nav_lat",NF90_REAL4, & + & nw_di((/k_1,k_2/),f_i),latid) + v_min = MINVAL(y_axis_2d) + v_max = MAXVAL(y_axis_2d) + ENDIF + i_rc = NF90_PUT_ATT(f_e,latid,"axis","Y") + i_rc = NF90_PUT_ATT(f_e,latid,'standard_name',"latitude") + i_rc = NF90_PUT_ATT(f_e,latid,'units',"degrees_north") + i_rc = NF90_PUT_ATT(f_e,latid,'valid_min',REAL(v_min,KIND=4)) + i_rc = NF90_PUT_ATT(f_e,latid,'valid_max',REAL(v_max,KIND=4)) + ENDIF +!- +! Define the Vertical axis +!- + IF (PRESENT(z_axis)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Vertical axis' + ENDIF +!--- + k_1=nw_ai(k_lev,f_i); +!--- + IF (SIZE(z_axis) /= nw_dl(k_1,f_i)) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid z_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF +!--- + v_min = MINVAL(z_axis) + v_max = MAXVAL(z_axis) +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_DEF_VAR(f_e,'lev',NF90_REAL4, & + & nw_di(k_1,f_i),levid) + i_rc = NF90_PUT_ATT(f_e,levid,"axis","Z") + i_rc = NF90_PUT_ATT(f_e,levid,'standard_name','model_level_number') + i_rc = NF90_PUT_ATT(f_e,levid,'units','sigma_level') + i_rc = NF90_PUT_ATT(f_e,levid,'long_name','Sigma Levels') + i_rc = NF90_PUT_ATT(f_e,levid,'valid_min',REAL(v_min,KIND=4)) + i_rc = NF90_PUT_ATT(f_e,levid,'valid_max',REAL(v_max,KIND=4)) + ENDIF +!- +! Define the Time axis +!- + IF (PRESENT(t_axis).AND.PRESENT(t_init).AND.PRESENT(t_step)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Define the Time axis' + ENDIF +!--- + k_1=nw_ai(k_tim,f_i); +!--- + IF ( (nw_dl(k_1,f_i) /= 0) & + & .AND.(SIZE(t_axis) /= nw_dl(k_1,f_i)) ) THEN + CALL ipslerr (3,'fliopstc', & + & 'Invalid t_axis dimension :', & + & 'not equal to the dimension', & + & 'defined at the creation of the file') + ENDIF +!-- Retrieve the calendar date + CALL lock_calendar (old_status=l_tmp) + IF (PRESENT(t_calendar)) THEN + CALL ioget_calendar (c_tmp1) + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(t_calendar)) + ENDIF + CALL ju2ymds (t_init,j_yy,j_mo,j_dd,r_ss) + IF (PRESENT(t_calendar)) THEN + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(c_tmp1)) + ENDIF + CALL lock_calendar (new_status=l_tmp) +!-- + k=NINT(r_ss) + j_hh=k/3600 + k=k-3600*j_hh + j_mn=k/60 + j_ss=k-60*j_mn +!-- Calculate the step unit + IF (ABS(t_step) >= 604800.) THEN + dt = t_step/604800. + c_tmp2 = 'weeks' + ELSE IF (ABS(t_step) >= 86400.) THEN + dt = t_step/86400. + c_tmp2 = 'days' + ELSE IF (ABS(t_step) >= 3600.) THEN + dt = t_step/3600. + c_tmp2 = 'hours' + ELSE IF (ABS(t_step) >= 60.) THEN + dt = t_step/60. + c_tmp2 = 'minutes' + ELSE + dt = t_step + c_tmp2 = 'seconds' + ENDIF +!--- + c_tmp1 = '' + IF (ABS(dt-NINT(dt)) <= ABS(10.*EPSILON(dt))) THEN + IF (NINT(dt) /= 1) THEN + WRITE (UNIT=c_tmp1,FMT='(I15)') NINT(dt) + ENDIF + ELSE + IF (dt < 1.) THEN + WRITE (UNIT=c_tmp1,FMT='(F8.5)') dt + ELSE + WRITE (UNIT=c_tmp1,FMT='(F17.5)') dt + ENDIF + DO k=LEN_TRIM(c_tmp1),1,-1 + IF (c_tmp1(k:k) /= '0') THEN + EXIT + ELSE + c_tmp1(k:k) = ' ' + ENDIF + ENDDO + ENDIF + c_tmp2 = TRIM(c_tmp1)//' '//TRIM(c_tmp2) + WRITE (UNIT=c_tmp3, & + & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & + & TRIM(ADJUSTL(c_tmp2))//' since ',j_yy,j_mo,j_dd,j_hh,j_mn,j_ss +!--- + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_DEF_VAR(f_e,'time',NF90_REAL4, & + & nw_di(k_1,f_i),timeid) + i_rc = NF90_PUT_ATT(f_e,timeid,"axis",'T') + i_rc = NF90_PUT_ATT(f_e,timeid,'standard_name','time') + i_rc = NF90_PUT_ATT(f_e,timeid,'long_name','time steps') + IF (PRESENT(t_calendar)) THEN + i_rc = NF90_PUT_ATT(f_e,timeid,'calendar',TRIM(t_calendar)) + ENDIF + i_rc = NF90_PUT_ATT(f_e,timeid,'units',TRIM(c_tmp3)) + ELSE IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN + CALL ipslerr (3,'fliopstc', & + & 'For time axis and coordinates', & + & 'arguments t_axis AND t_init AND t_step', & + & 'must be PRESENT') + ENDIF +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- +! Create the longitude axis +!- + IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Longitude axis' + ENDIF + IF (PRESENT(x_axis)) THEN + i_rc = NF90_PUT_VAR(f_e,lonid,x_axis(:)) + ELSE + i_rc = NF90_PUT_VAR(f_e,lonid,x_axis_2d(:,:)) + ENDIF + ENDIF +!- +! Create the Latitude axis +!- + IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Latitude axis' + ENDIF + IF (PRESENT(y_axis)) THEN + i_rc = NF90_PUT_VAR(f_e,latid,y_axis(:)) + ELSE + i_rc = NF90_PUT_VAR(f_e,latid,y_axis_2d(:,:)) + ENDIF + ENDIF +!- +! Create the Vertical axis +!- + IF (PRESENT(z_axis)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Vertical axis' + ENDIF + i_rc = NF90_PUT_VAR(f_e,levid,z_axis(:)) + ENDIF +!- +! Create the Time axis +!- + IF (PRESENT(t_axis)) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliopstc : Create the Time axis' + ENDIF + i_rc = NF90_PUT_VAR(f_e,timeid,REAL(t_axis(:))) + ENDIF +!- +! Keep all this information +!- + CALL flio_inf (f_e,nb_vars=nw_nv(f_i),nb_atts=nw_na(f_i)) +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliopstc" + ENDIF +!---------------------- +END SUBROUTINE fliopstc +!=== +SUBROUTINE fliodv_r0d & + & (f_i,v_n,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER,OPTIONAL,INTENT(IN) :: v_t + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & + & axis,standard_name,long_name,units + REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue +!--------------------------------------------------------------------- + CALL flio_udv & + & (f_i,0,v_n,(/0/),v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!------------------------ +END SUBROUTINE fliodv_r0d +!=== +SUBROUTINE fliodv_rnd & + & (f_i,v_n,v_d,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER,DIMENSION(:),INTENT(IN) :: v_d + INTEGER,OPTIONAL,INTENT(IN) :: v_t + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & + & axis,standard_name,long_name,units + REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue +!--------------------------------------------------------------------- + CALL flio_udv & + & (f_i,SIZE(v_d),v_n,v_d,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!------------------------ +END SUBROUTINE fliodv_rnd +!=== +SUBROUTINE flio_udv & + & (f_i,n_d,v_n,v_d,v_t, & + & axis,standard_name,long_name,units,valid_min,valid_max,fillvalue) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i,n_d + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER,DIMENSION(:),INTENT(IN) :: v_d + INTEGER,OPTIONAL,INTENT(IN) :: v_t + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: & + & axis,standard_name,long_name,units + REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue +!- + INTEGER :: f_e,m_k,i_v,i_rc,ii,idd + INTEGER,DIMENSION(nb_vd_mx) :: a_i +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliodefv ",TRIM(v_n)," ",n_d,"D" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliodefv',f_i,f_e) +!- + IF (n_d > 0) THEN + IF (n_d > nb_vd_mx) THEN + CALL ipslerr (3,'fliodefv', & + & 'Too many dimensions', & + & 'required for the variable',TRIM(v_n)) + ENDIF + ENDIF +!- + DO ii=1,n_d + IF ( (v_d(ii) >= 1).AND.(v_d(ii) <= nb_fd_mx) ) THEN + idd = nw_di(v_d(ii),f_i) + IF (idd > 0) THEN + a_i(ii) = idd + ELSE + CALL ipslerr (3,'fliodefv', & + & 'Invalid dimension identifier','(not defined)',' ') + ENDIF + ELSE + CALL ipslerr (3,'fliodefv', & + & 'Invalid dimension identifier','(not supported)',' ') + ENDIF + ENDDO +!- + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL flio_hdm (f_i,f_e,.TRUE.) +!--- + IF (PRESENT(v_t)) THEN + SELECT CASE (v_t) + CASE(flio_i) + IF (i_std == i_8) THEN +!-------- I8 not yet supported by NETCDF +!-------- m_k = flio_i8 + m_k = flio_i4 + ELSE + m_k = flio_i4 + ENDIF + CASE(flio_r) + IF (r_std == r_8) THEN + m_k = flio_r8 + ELSE + m_k = flio_r4 + ENDIF + CASE(flio_c,flio_i1,flio_i2,flio_i4,flio_r4,flio_r8) + m_k = v_t + CASE DEFAULT + CALL ipslerr (3,'fliodefv', & + & 'Variable '//TRIM(v_n),'External type','not supported') + END SELECT + ELSE IF (r_std == r_8) THEN + m_k = flio_r8 + ELSE + m_k = flio_r4 + ENDIF +!--- + IF (n_d > 0) THEN + i_rc = NF90_DEF_VAR(f_e,v_n,m_k,a_i(1:n_d),i_v) + ELSE + i_rc = NF90_DEF_VAR(f_e,v_n,m_k,i_v) + ENDIF + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliodefv', & + & 'Variable '//TRIM(v_n)//' not defined','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + nw_nv(f_i) = nw_nv(f_i)+1 +!--- + IF (PRESENT(axis)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'axis',TRIM(axis)) + ENDIF + IF (PRESENT(standard_name)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'standard_name',TRIM(standard_name)) + ENDIF + IF (PRESENT(long_name)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'long_name',TRIM(long_name)) + ENDIF + IF (PRESENT(units)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,'units',TRIM(units)) + ENDIF + IF (PRESENT(valid_min)) THEN + SELECT CASE (m_k) + CASE(flio_i1,flio_i2) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_2)) + CASE(flio_i4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_4)) + CASE(flio_r4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_4)) + CASE(flio_r8) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_8)) + CASE DEFAULT + CALL ipslerr (2,'fliodefv', & + & 'Variable '//TRIM(v_n),'attribute valid_min', & + & 'not supported for this external type') + END SELECT + ENDIF + IF (PRESENT(valid_max)) THEN + SELECT CASE (m_k) + CASE(flio_i1,flio_i2) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_2)) + CASE(flio_i4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_4)) + CASE(flio_r4) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_4)) + CASE(flio_r8) + i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_8)) + CASE DEFAULT + CALL ipslerr (2,'fliodefv', & + & 'Variable '//TRIM(v_n),'attribute valid_max', & + & 'not supported for this external type') + END SELECT + ENDIF + IF (PRESENT(fillvalue)) THEN + SELECT CASE (m_k) + CASE(flio_i1,flio_i2) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_2)) + CASE(flio_i4) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_4)) + CASE(flio_r4) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_4)) + CASE(flio_r8) + i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_8)) + CASE DEFAULT + CALL ipslerr (2,'fliodefv', & + & 'Variable '//TRIM(v_n),'attribute fillvalue', & + & 'not supported for this external type') + END SELECT + ENDIF +!--- + ELSE + CALL ipslerr (3,'fliodefv','Variable',TRIM(v_n),'already exist') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliodefv" + ENDIF +!---------------------- +END SUBROUTINE flio_udv +!=== +SUBROUTINE fliopv_i40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_i40 +!=== +SUBROUTINE fliopv_i41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i41 +!=== +SUBROUTINE fliopv_i42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i42 +!=== +SUBROUTINE fliopv_i43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i43 +!=== +SUBROUTINE fliopv_i44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i44 +!=== +SUBROUTINE fliopv_i45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i45 +!=== +SUBROUTINE fliopv_i20 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_20=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_i20 +!=== +SUBROUTINE fliopv_i21 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_21=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i21 +!=== +SUBROUTINE fliopv_i22 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_22=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i22 +!=== +SUBROUTINE fliopv_i23 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_23=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i23 +!=== +SUBROUTINE fliopv_i24 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_24=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i24 +!=== +SUBROUTINE fliopv_i25 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,i_25=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_i25 +!=== +!?INTEGERS of KIND 1 are not supported on all computers +!?SUBROUTINE fliopv_i10 (f_i,v_n,v_v,start) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_10=v_v,start=start) +!?!------------------------ +!?END SUBROUTINE fliopv_i10 +!?!=== +!?SUBROUTINE fliopv_i11 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_11=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i11 +!?!=== +!?SUBROUTINE fliopv_i12 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_12=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i12 +!?!=== +!?SUBROUTINE fliopv_i13 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_13=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i13 +!?!=== +!?SUBROUTINE fliopv_i14 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_14=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i14 +!?!=== +!?SUBROUTINE fliopv_i15 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_upv (f_i,v_n,i_15=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliopv_i15 +!=== +SUBROUTINE fliopv_r40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_r40 +!=== +SUBROUTINE fliopv_r41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r41 +!=== +SUBROUTINE fliopv_r42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r42 +!=== +SUBROUTINE fliopv_r43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r43 +!=== +SUBROUTINE fliopv_r44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r44 +!=== +SUBROUTINE fliopv_r45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r45 +!=== +SUBROUTINE fliopv_r80 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_80=v_v,start=start) +!------------------------ +END SUBROUTINE fliopv_r80 +!=== +SUBROUTINE fliopv_r81 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_81=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r81 +!=== +SUBROUTINE fliopv_r82 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_82=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r82 +!=== +SUBROUTINE fliopv_r83 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_83=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r83 +!=== +SUBROUTINE fliopv_r84 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_84=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r84 +!=== +SUBROUTINE fliopv_r85 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_upv (f_i,v_n,r_85=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliopv_r85 +!=== +SUBROUTINE flio_upv & + & (f_i,v_n, & + & i_40,i_41,i_42,i_43,i_44,i_45, & + & i_20,i_21,i_22,i_23,i_24,i_25, & +!? & i_10,i_11,i_12,i_13,i_14,i_15, & + & r_40,r_41,r_42,r_43,r_44,r_45, & + & r_80,r_81,r_82,r_83,r_84,r_85, & + & start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(IN),OPTIONAL :: i_40 + INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN),OPTIONAL :: i_41 + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_42 + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_43 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_44 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_45 + INTEGER(KIND=i_2),INTENT(IN),OPTIONAL :: i_20 + INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN),OPTIONAL :: i_21 + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_22 + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_23 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_24 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_25 +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER(KIND=i_1),INTENT(IN),OPTIONAL :: i_10 +!?INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN),OPTIONAL :: i_11 +!?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_12 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_13 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_14 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_15 + REAL(KIND=r_4),INTENT(IN),OPTIONAL :: r_40 + REAL(KIND=r_4),DIMENSION(:),INTENT(IN),OPTIONAL :: r_41 + REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_42 + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_43 + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_44 + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_45 + REAL(KIND=r_8),INTENT(IN),OPTIONAL :: r_80 + REAL(KIND=r_8),DIMENSION(:),INTENT(IN),OPTIONAL :: r_81 + REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_82 + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_83 + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_84 + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_85 + INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count +!- + INTEGER :: f_e,i_v,i_rc + CHARACTER(LEN=5) :: cvr_d +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + IF (PRESENT(i_40)) THEN; cvr_d = "I1 0D"; + ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D"; + ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D"; + ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D"; + ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D"; + ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D"; + ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D"; + ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D"; + ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D"; + ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D"; + ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D"; + ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D"; +!? ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D"; +!? ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D"; +!? ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D"; +!? ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D"; +!? ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D"; +!? ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D"; + ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D"; + ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D"; + ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D"; + ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D"; + ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D"; + ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D"; + ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D"; + ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D"; + ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D"; + ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D"; + ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D"; + ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D"; + ENDIF + WRITE(*,*) "->flioputv ",TRIM(v_n)," ",TRIM(cvr_d) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioputv',f_i,f_e) +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc == NF90_NOERR) THEN + IF (PRESENT(i_40)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_40,start=start) + ELSE IF (PRESENT(i_41)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_41,start=start,count=count) + ELSE IF (PRESENT(i_42)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_42,start=start,count=count) + ELSE IF (PRESENT(i_43)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_43,start=start,count=count) + ELSE IF (PRESENT(i_44)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_44,start=start,count=count) + ELSE IF (PRESENT(i_45)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_45,start=start,count=count) + ELSE IF (PRESENT(i_20)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_20,start=start) + ELSE IF (PRESENT(i_21)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_21,start=start,count=count) + ELSE IF (PRESENT(i_22)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_22,start=start,count=count) + ELSE IF (PRESENT(i_23)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_23,start=start,count=count) + ELSE IF (PRESENT(i_24)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_24,start=start,count=count) + ELSE IF (PRESENT(i_25)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,i_25,start=start,count=count) +!? ELSE IF (PRESENT(i_10)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_10,start=start) +!? ELSE IF (PRESENT(i_11)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_11,start=start,count=count) +!? ELSE IF (PRESENT(i_12)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_12,start=start,count=count) +!? ELSE IF (PRESENT(i_13)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_13,start=start,count=count) +!? ELSE IF (PRESENT(i_14)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_14,start=start,count=count) +!? ELSE IF (PRESENT(i_15)) THEN +!? i_rc = NF90_PUT_VAR(f_e,i_v,i_15,start=start,count=count) + ELSE IF (PRESENT(r_40)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_40,start=start) + ELSE IF (PRESENT(r_41)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_41,start=start,count=count) + ELSE IF (PRESENT(r_42)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_42,start=start,count=count) + ELSE IF (PRESENT(r_43)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_43,start=start,count=count) + ELSE IF (PRESENT(r_44)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_44,start=start,count=count) + ELSE IF (PRESENT(r_45)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_45,start=start,count=count) + ELSE IF (PRESENT(r_80)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_80,start=start) + ELSE IF (PRESENT(r_81)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_81,start=start,count=count) + ELSE IF (PRESENT(r_82)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_82,start=start,count=count) + ELSE IF (PRESENT(r_83)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_83,start=start,count=count) + ELSE IF (PRESENT(r_84)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_84,start=start,count=count) + ELSE IF (PRESENT(r_85)) THEN + i_rc = NF90_PUT_VAR(f_e,i_v,r_85,start=start,count=count) + ENDIF + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioputv', & + & 'Variable '//TRIM(v_n)//' not put','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + ELSE + CALL ipslerr (3,'flioputv','Variable',TRIM(v_n),'not defined') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioputv" + ENDIF +!---------------------- +END SUBROUTINE flio_upv +!=== +SUBROUTINE fliopa_r4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avr4=(/a_v/)) +!-------------------------- +END SUBROUTINE fliopa_r4_0d +!=== +SUBROUTINE fliopa_r4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),DIMENSION(:),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr4=a_v) +!-------------------------- +END SUBROUTINE fliopa_r4_1d +!=== +SUBROUTINE fliopa_r8_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avr8=(/a_v/)) +!-------------------------- +END SUBROUTINE fliopa_r8_0d +!=== +SUBROUTINE fliopa_r8_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),DIMENSION(:),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr8=a_v) +!-------------------------- +END SUBROUTINE fliopa_r8_1d +!=== +SUBROUTINE fliopa_i4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avi4=(/a_v/)) +!-------------------------- +END SUBROUTINE fliopa_i4_0d +!=== +SUBROUTINE fliopa_i4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),DIMENSION(:),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avi4=a_v) +!-------------------------- +END SUBROUTINE fliopa_i4_1d +!=== +SUBROUTINE fliopa_tx_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + CHARACTER(LEN=*),INTENT(IN) :: a_v +!--------------------------------------------------------------------- + CALL flio_upa (f_i,1,v_n,a_n,avtx=a_v) +!-------------------------- +END SUBROUTINE fliopa_tx_0d +!=== +SUBROUTINE flio_upa (f_i,l_a,v_n,a_n,avr4,avr8,avi4,avtx) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i,l_a + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr4 + REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr8 + INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avi4 + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: avtx +!- + INTEGER :: f_e,i_v,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioputa ",TRIM(v_n)," ",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioputa',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioputa', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a) + IF ( (i_v == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN + nw_na(f_i) = nw_na(f_i)+1 + ENDIF + CALL flio_hdm (f_i,f_e,.TRUE.) + IF (PRESENT(avr4)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr4(1:l_a)) + ELSE IF (PRESENT(avr8)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr8(1:l_a)) + ELSE IF (PRESENT(avi4)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avi4(1:l_a)) + ELSE IF (PRESENT(avtx)) THEN + i_rc = NF90_PUT_ATT(f_e,i_v,a_n,TRIM(avtx)) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioputa" + ENDIF +!---------------------- +END SUBROUTINE flio_upa +!=== +SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: f_n + INTEGER,INTENT(OUT) :: f_i + CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: mode + INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat +!- + INTEGER :: i_rc,f_e,m_c +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) '->flioopfd, file name : ',TRIM(f_n) + ENDIF +!- +! Search for a free local identifier +!- + f_i = flio_rid() + IF (f_i < 0) THEN + CALL ipslerr (3,'flioopfd', & + 'Too many files.','Please increase nb_fi_mx', & + 'in module fliocom.f90.') + ENDIF +!- +! Check the mode +!- + IF (PRESENT(mode)) THEN + IF (TRIM(mode) == "WRITE") THEN + m_c = NF90_WRITE + ELSE + m_c = NF90_NOWRITE + ENDIF + ELSE + m_c = NF90_NOWRITE + ENDIF +!- +! Open the file. +!- + i_rc = NF90_OPEN(TRIM(f_n),m_c,f_e) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioopfd', & + & 'Could not open file :',TRIM(f_n), & + & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) ' flioopfd, model file-id : ',f_e + ENDIF +!- +! Retrieve and keep information about the file +!- + nw_id(f_i) = f_e + lw_hm(f_i) = .FALSE. + CALL flio_inf (f_e, & + & nb_dims=nw_nd(f_i),nb_vars=nw_nv(f_i), & + & nb_atts=nw_na(f_i),id_unlm=nw_un(f_i), & + & nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i)) +!- +! Return information to the user +!- + IF (PRESENT(nb_dim)) THEN + nb_dim = nw_nd(f_i) + ENDIF + IF (PRESENT(nb_var)) THEN + nb_var = nw_nv(f_i) + ENDIF + IF (PRESENT(nb_gat)) THEN + nb_gat = nw_na(f_i) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,'(" flioopfd - dimensions :",/,(5(1X,I10),:))') & + & nw_dl(:,f_i) + WRITE(*,*) "<-flioopfd" + ENDIF +!---------------------- +END SUBROUTINE flioopfd +!=== +SUBROUTINE flioinqf & + & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat,id_uld + INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: id_dim,ln_dim +!- + INTEGER :: lll +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqf" + ENDIF +!- + IF ( (f_i < 1).OR.(f_i > nb_fi_mx) ) THEN + CALL ipslerr (2,'flioinqf', & + & 'Invalid file identifier',' ',' ') + ELSE IF (nw_id(f_i) <= 0) THEN + CALL ipslerr (2,'flioinqf', & + & 'Unable to inquire about the file :','probably','not opened') + ELSE + IF (PRESENT(nb_dim)) THEN + nb_dim = nw_nd(f_i) + ENDIF + IF (PRESENT(nb_var)) THEN + nb_var = nw_nv(f_i) + ENDIF + IF (PRESENT(nb_gat)) THEN + nb_gat = nw_na(f_i) + ENDIF + IF (PRESENT(id_uld)) THEN + id_uld = nw_un(f_i) + ENDIF + IF (PRESENT(id_dim)) THEN + lll = SIZE(id_dim) + IF (lll < nw_nd(f_i)) THEN + CALL ipslerr (2,'flioinqf', & + & 'Only the first identifiers', & + & 'of the dimensions','will be returned') + ENDIF + lll=MIN(SIZE(id_dim),nw_nd(f_i)) + id_dim(1:lll) = nw_di(1:lll,f_i) + ENDIF + IF (PRESENT(ln_dim)) THEN + lll = SIZE(ln_dim) + IF (lll < nw_nd(f_i)) THEN + CALL ipslerr (2,'flioinqf', & + & 'Only the first lengths', & + & 'of the dimensions','will be returned') + ENDIF + lll=MIN(SIZE(ln_dim),nw_nd(f_i)) + ln_dim(1:lll) = nw_dl(1:lll,f_i) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqf" + ENDIF +!---------------------- +END SUBROUTINE flioinqf +!=== +SUBROUTINE flioinqn & + & (f_i,cn_dim,cn_var,cn_gat,cn_uld, & + & id_start,id_count,iv_start,iv_count,ia_start,ia_count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: & + & cn_dim,cn_var,cn_gat + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: & + & cn_uld + INTEGER,OPTIONAL,INTENT(IN) :: & + & id_start,id_count,iv_start,iv_count,ia_start,ia_count +!- + INTEGER :: f_e,i_s,i_w,iws,iwc,i_rc + LOGICAL :: l_ok +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqn" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioinqn',f_i,f_e) +!- + IF (PRESENT(cn_dim)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_dim) + DO i_w=1,i_s + cn_dim(i_w)(:) = '?' + ENDDO + IF (PRESENT(id_start)) THEN + iws = id_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(id_count)) THEN + iwc = id_count + ELSE + iwc = nw_nd(f_i) + ENDIF + IF (iws > nw_nd(f_i)) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested dimensions', & + & 'is greater than the number of dimensions', & + & 'in the file') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested dimensions', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF ((iws+iwc-1) > nw_nd(f_i)) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of requested dimensions', & + & 'is greater than the number of dimensions', & + & 'in the file') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of dimensions to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first dimensions of the file will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The number of requested dimensions', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,nw_nd(f_i)-iws+1) + i_rc = NF90_INQUIRE_DIMENSION(f_e,i_w+iws-1,name=cn_dim(i_w)) + ENDDO + ENDIF + ENDIF +!- + IF (PRESENT(cn_var)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_var) + DO i_w=1,i_s + cn_var(i_w)(:) = '?' + ENDDO + IF (PRESENT(iv_start)) THEN + iws = iv_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(iv_count)) THEN + iwc = iv_count + ELSE + iwc = nw_nv(f_i) + ENDIF + IF (iws > nw_nv(f_i)) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested variables', & + & 'is greater than the number of variables', & + & 'in the file') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested variables', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF ((iws+iwc-1) > nw_nv(f_i)) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of requested variables', & + & 'is greater than the number of variables', & + & 'in the file') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of variables to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first variables of the file will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The number of requested variables', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,nw_nv(f_i)-iws+1) + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_w+iws-1,name=cn_var(i_w)) + ENDDO + ENDIF + ENDIF +!- + IF (PRESENT(cn_gat)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_gat) + DO i_w=1,i_s + cn_gat(i_w)(:) = '?' + ENDDO + IF (PRESENT(ia_start)) THEN + iws = ia_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(ia_count)) THEN + iwc = ia_count + ELSE + iwc = nw_na(f_i) + ENDIF + IF (iws > nw_na(f_i)) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested global attributes', & + & 'is greater than the number of global attributes', & + & 'in the file') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The start index of requested global attributes', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF ((iws+iwc-1) > nw_na(f_i)) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of requested global attributes', & + & 'is greater than the number of global attributes', & + & 'in the file') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqn', & + & 'The number of global attributes to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first global attributes of the file will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqn', & + & 'The number of requested global attributes', & + & 'is invalid', & + & '( < 1 )') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,nw_na(f_i)-iws+1) + i_rc = NF90_INQ_ATTNAME(f_e, & + & NF90_GLOBAL,i_w+iws-1,name=cn_gat(i_w)) + ENDDO + ENDIF + ENDIF +!- + IF (PRESENT(cn_uld)) THEN + cn_uld = '?' + IF (nw_un(f_i) > 0) THEN + i_rc = NF90_INQUIRE_DIMENSION(f_e,nw_un(f_i),name=cn_uld) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqn" + ENDIF +!---------------------- +END SUBROUTINE flioinqn +!=== +SUBROUTINE fliogstc & + & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, & + & t_axis,t_init,t_step,t_calendar, & + & x_start,x_count,y_start,y_count, & + & z_start,z_count,t_start,t_count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + REAL,DIMENSION(:),OPTIONAL,INTENT(OUT) :: x_axis,y_axis + REAL,DIMENSION(:,:),OPTIONAL,INTENT(OUT) :: x_axis_2d,y_axis_2d + REAL,DIMENSION(:),OPTIONAL,INTENT(OUT) :: z_axis + INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: t_axis + REAL,OPTIONAL,INTENT(OUT) :: t_init,t_step + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: t_calendar + INTEGER,OPTIONAL,INTENT(IN) :: & + & x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count +!- + INTEGER :: i_rc,f_e,i_v,it_t,nbdim,kv + INTEGER :: m_x,i_x,l_x,m_y,i_y,l_y,m_z,i_z,l_z,m_t,i_t,l_t + CHARACTER(LEN=NF90_MAX_NAME) :: name + CHARACTER(LEN=80) :: units + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=1) :: c_1 + REAL :: r_yy,r_mo,r_dd,r_ss,dtv,dtn + INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss + LOGICAL :: l_ok,l_tmp +!- + REAL,DIMENSION(:),ALLOCATABLE :: v_tmp +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliogstc" + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliogstc',f_i,f_e) +!- +! Validate the coherence of the arguments +!- + IF ( (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) & + & .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN + CALL ipslerr (3,'fliogstc', & + & 'The [x/y]_axis arguments', & + & 'are not coherent :',& + & 'can not handle two [x/y]_axis') + ENDIF +!- +! Retrieve spatio-temporal dimensions +!- + IF (nw_ai(k_lon,f_i) > 0) THEN + m_x = nw_dl(nw_ai(k_lon,f_i),f_i); + ELSE + m_x = -1; + ENDIF + IF (nw_ai(k_lat,f_i) > 0) THEN + m_y = nw_dl(nw_ai(k_lat,f_i),f_i); + ELSE + m_y = -1; + ENDIF + IF (nw_ai(k_lev,f_i) > 0) THEN + m_z = nw_dl(nw_ai(k_lev,f_i),f_i); + ELSE + m_z = -1; + ENDIF + IF (nw_ai(k_tim,f_i) > 0) THEN + m_t = nw_dl(nw_ai(k_tim,f_i),f_i); + ELSE + m_t = -1; + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,'(" fliogstc - dimensions :",/,(5(1X,I10),:))') & + & m_x,m_y,m_z,m_t + ENDIF +!- +! Initialize the x-y indices +!- + IF ( PRESENT(x_axis) & + & .OR.PRESENT(x_axis_2d) & + & .OR.PRESENT(y_axis_2d) ) THEN + IF (PRESENT(x_start)) THEN + i_x = x_start + ELSE + i_x = 1 + ENDIF + IF (PRESENT(x_count)) THEN + l_x = x_count + ELSE + l_x = m_x-i_x+1 + ENDIF + ENDIF + IF ( PRESENT(y_axis) & + & .OR.PRESENT(y_axis_2d) & + & .OR.PRESENT(x_axis_2d) ) THEN + IF (PRESENT(y_start)) THEN + i_y = y_start + ELSE + i_y = 1 + ENDIF + IF (PRESENT(y_count)) THEN + l_y = y_count + ELSE + l_y = m_y-i_y+1 + ENDIF + ENDIF + IF (PRESENT(x_axis)) THEN + IF (m_x <= 0) THEN + CALL ipslerr (3,'fliogstc', & + & 'Requested x_axis', & + & 'but the coordinate is not present','in the file') + ELSE IF ((i_x+l_x-1) > m_x) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the x_axis', & + & 'is greater than the size of the coordinate','in the file') + ENDIF + ENDIF + IF (PRESENT(y_axis)) THEN + IF (m_y <= 0) THEN + CALL ipslerr (3,'fliogstc', & + & 'Requested y_axis', & + & 'but the coordinate is not present','in the file') + ELSE IF ((i_y+l_y-1) > m_y) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the y_axis', & + & 'is greater than the size of the coordinate','in the file') + ENDIF + ENDIF + IF (PRESENT(x_axis_2d).OR.PRESENT(y_axis_2d) )THEN + IF ( (m_x <= 0).OR.(m_y <= 0) ) THEN + CALL ipslerr (3,'fliogstc', & + & 'Requested [x/y]_axis_2d', & + & 'but the coordinates are not iboth present','in the file') + ELSE IF ( ((i_x+l_x-1) > m_x).OR.((i_y+l_y-1) > m_y) ) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the [x/y]_axis_2d', & + & 'is greater than the size of the coordinate','in the file') + ENDIF + ENDIF +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- +! Extracting the x coordinate, if needed +!- + IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN + CALL flio_qax (f_i,'x',i_v,nbdim) + IF (i_v > 0) THEN + IF (nbdim == 1) THEN + IF (PRESENT(x_axis)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,x_axis, & + & start=(/i_x/),count=(/l_x/)) + ELSE + ALLOCATE(v_tmp(l_x)) + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_x/),count=(/l_x/)) + DO kv=1,l_y + x_axis_2d(:,kv) = v_tmp(:) + ENDDO + DEALLOCATE(v_tmp) + ENDIF + ELSE IF (nbdim == 2) THEN + IF (PRESENT(x_axis)) THEN + l_ok = .TRUE. + IF (l_y > 1) THEN + ALLOCATE(v_tmp(l_y)) + DO kv=i_x,i_x+l_x-1 + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/kv,i_y/),count=(/1,l_y/)) + IF (ANY(v_tmp(2:l_y) /= v_tmp(1))) THEN + l_ok = .FALSE. + EXIT + ENDIF + ENDDO + DEALLOCATE(v_tmp) + ENDIF + IF (l_ok) THEN + i_rc = NF90_GET_VAR(f_e,i_v,x_axis, & + & start=(/i_x,i_y/),count=(/l_x,1/)) + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Requested 1D x_axis', & + & 'which have 2 not regular dimensions', & + & 'in the file') + ENDIF + ELSE + i_rc = NF90_GET_VAR(f_e,i_v,x_axis_2d, & + & start=(/i_x,i_y/),count=(/l_x,l_y/)) + ENDIF + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Can not handle x_axis', & + & 'that have more than 2 dimensions', & + & 'in the file') + ENDIF + ELSE + CALL ipslerr (3,'fliogstc','No x_axis found','in the file',' ') + ENDIF + ENDIF +!- +! Extracting the y coordinate, if needed +!- + IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN + CALL flio_qax (f_i,'y',i_v,nbdim) + IF (i_v > 0) THEN + IF (nbdim == 1) THEN + IF (PRESENT(y_axis)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,y_axis, & + & start=(/i_y/),count=(/l_y/)) + ELSE + ALLOCATE(v_tmp(l_y)) + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_y/),count=(/l_y/)) + DO kv=1,l_x + y_axis_2d(kv,:) = v_tmp(:) + ENDDO + DEALLOCATE(v_tmp) + ENDIF + ELSE IF (nbdim == 2) THEN + IF (PRESENT(y_axis)) THEN + l_ok = .TRUE. + IF (l_x > 1) THEN + ALLOCATE(v_tmp(l_x)) + DO kv=i_y,i_y+l_y-1 + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_x,kv/),count=(/l_x,1/)) + IF (ANY(v_tmp(2:l_x) /= v_tmp(1))) THEN + l_ok = .FALSE. + EXIT + ENDIF + ENDDO + DEALLOCATE(v_tmp) + ENDIF + IF (l_ok) THEN + i_rc = NF90_GET_VAR(f_e,i_v,y_axis, & + & start=(/i_x,i_y/),count=(/1,l_y/)) + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Requested 1D y_axis', & + & 'which have 2 not regular dimensions', & + & 'in the file') + ENDIF + ELSE + i_rc = NF90_GET_VAR(f_e,i_v,y_axis_2d, & + & start=(/i_x,i_y/),count=(/l_x,l_y/)) + ENDIF + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Can not handle y axis', & + & 'that have more than 2 dimensions', & + & 'in the file') + ENDIF + ELSE + CALL ipslerr (3,'fliogstc','No y_axis found','in the file',' ') + ENDIF + ENDIF +!- +! Extracting the z coordinate, if needed +!- + IF (PRESENT(z_axis)) THEN + IF (PRESENT(z_start)) THEN + i_z = z_start + ELSE + i_z = 1 + ENDIF + IF (PRESENT(z_count)) THEN + l_z = z_count + ELSE + l_z = m_z-i_z+1 + ENDIF + IF ((i_z+l_z-1) > m_z) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the z axis', & + & 'is greater than the size of the coordinate',& + & 'in the file') + ENDIF + CALL flio_qax (f_i,'z',i_v,nbdim) + IF (i_v > 0) THEN + IF (nbdim == 1) THEN + i_rc = NF90_GET_VAR(f_e,i_v,z_axis, & + & start=(/i_z/),count=(/l_z/)) + ELSE + CALL ipslerr (3,'fliogstc', & + & 'Can not handle z_axis', & + & 'that have more than 1 dimension', & + & 'in the file') + ENDIF + ELSE + CALL ipslerr (3,'fliogstc','No z_axis found','in the file',' ') + ENDIF + ENDIF +!- +! Extracting the t coordinate, if needed +!- + IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN + CALL flio_qax (f_i,'t',i_v,nbdim) + IF (i_v < 0) THEN + CALL ipslerr (3,'fliogstc','No t_axis found','in the file',' ') + ENDIF +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliogstc - get time details' + ENDIF +!--- +!-- Get all the details for the time +!-- Prefered method is '"time_steps" since' +!--- + name='' + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,name=name) + units='' + i_rc = NF90_GET_ATT(f_e,i_v,'units',units) + IF (INDEX(units,' since ') > 0) THEN + it_t = 1 + ELSE IF (INDEX(name,'tstep') > 0) THEN + it_t = 2 + ELSE + it_t = 0; + ENDIF + ENDIF +!- +! Extracting the t coordinate, if needed +!- + IF (PRESENT(t_axis)) THEN + IF (PRESENT(t_start)) THEN + i_t = t_start + ELSE + i_t = 1 + ENDIF + IF (PRESENT(t_count)) THEN + l_t = t_count + ELSE + l_t = m_t-i_t+1 + ENDIF + IF ((i_t+l_t-1) > m_t) THEN + CALL ipslerr (3,'fliogstc', & + & 'The requested size for the t axis', & + & 'is greater than the size of the coordinate',& + & 'in the file') + ENDIF + ALLOCATE(v_tmp(l_t)) + i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, & + & start=(/i_t/),count=(/l_t/)) + t_axis(1:l_t) = NINT(v_tmp(1:l_t)) + DEALLOCATE(v_tmp) +!--- + IF (l_dbg) THEN + WRITE(*,*) ' fliogstc - first time : ',t_axis(1:1) + ENDIF + ENDIF +!- +! Extracting the time at the beginning, if needed +!- + IF (PRESENT(t_init)) THEN +!-- Find the calendar + CALL lock_calendar (old_status=l_tmp) + CALL ioget_calendar (c_tmp) + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units) + IF (i_rc == NF90_NOERR) THEN + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(units)) + ENDIF + IF (it_t == 1) THEN + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'units',units) + units = units(INDEX(units,' since ')+7:LEN_TRIM(units)) + READ (units,'(I4.4,5(A,I2.2))') & + & j_yy,c_1,j_mo,c_1,j_dd,c_1,j_hh,c_1,j_mn,c_1,j_ss + r_ss = j_hh*3600.+j_mn*60.+j_ss + CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init) + ELSE IF (it_t == 2) THEN + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'year0',r_yy) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'month0',r_mo) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'day0',r_dd) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'sec0',r_ss) + j_yy = NINT(r_yy); j_mo = NINT(r_mo); j_dd = NINT(r_dd); + CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init) + ELSE + t_init = 0. + ENDIF + CALL lock_calendar (new_status=.FALSE.) + CALL ioconf_calendar (TRIM(c_tmp)) + CALL lock_calendar (new_status=l_tmp) + IF (l_dbg) THEN + WRITE(*,*) ' fliogstc - time_type : ' + WRITE(*,*) it_t + WRITE(*,*) ' fliogstc - year month day second t_init : ' + WRITE(*,*) j_yy,j_mo,j_dd,r_ss,t_init + ENDIF + ENDIF +!- +! Extracting the timestep in seconds, if needed +!- + IF (PRESENT(t_step)) THEN + IF (it_t == 1) THEN + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'units',units) + units = ADJUSTL(units(1:INDEX(units,' since ')-1)) + dtn = 1. + IF (INDEX(units,"week") /= 0) THEN + kv = INDEX(units,"week") + dtv = 604800. + ELSE IF (INDEX(units,"day") /= 0) THEN + kv = INDEX(units,"day") + dtv = 86400. + ELSE IF (INDEX(units,"h") /= 0) THEN + kv = INDEX(units,"h") + dtv = 3600. + ELSE IF (INDEX(units,"min") /= 0) THEN + kv = INDEX(units,"min") + dtv = 60. + ELSE IF (INDEX(units,"sec") /= 0) THEN + kv = INDEX(units,"sec") + dtv = 1. + ELSE IF (INDEX(units,"timesteps") /= 0) THEN + kv = INDEX(units,"timesteps") + i_rc = NF90_GET_ATT(f_e,i_v,'tstep_sec',dtv) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogstc','"timesteps" value', & + & 'not found','in the file') + ENDIF + ELSE + kv = 1 + dtv = 1. + ENDIF + IF (kv > 1) THEN + READ (unit=units(1:kv-1),FMT=*) dtn + ENDIF + t_step = dtn*dtv + ELSE IF (it_t == 2) THEN + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'delta_tstep_sec',t_step) + ELSE + t_step = 1. + ENDIF + ENDIF +!- +! Extracting the calendar attribute, if needed +!- + IF (PRESENT(t_calendar)) THEN + units = '' + i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units) + IF (i_rc == NF90_NOERR) THEN + t_calendar = units + ELSE + t_calendar = "not found" + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliogstc" + ENDIF +!---------------------- +END SUBROUTINE fliogstc +!=== +SUBROUTINE flioinqv & + & (f_i,v_n,l_ex,v_t,nb_dims,len_dims,id_dims, & + & nb_atts,cn_atts,ia_start,ia_count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + LOGICAL,INTENT(OUT) :: l_ex + INTEGER,OPTIONAL,INTENT(OUT) :: v_t,nb_dims,nb_atts + INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: len_dims,id_dims + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cn_atts + INTEGER,OPTIONAL,INTENT(IN) :: ia_start,ia_count +!- + INTEGER :: f_e,i_v,n_w,i_s,i_w,iws,iwc,i_rc + LOGICAL :: l_ok + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dim_ids +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqv ",TRIM(v_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioinqv',f_i,f_e) +!- + i_v = -1 + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) +!- + l_ex = ( (i_v >= 0).AND.(i_rc == NF90_NOERR) ) +!- + IF (l_ex) THEN + IF (PRESENT(v_t)) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,xtype=v_t) + ENDIF + n_w = -1 + IF (PRESENT(nb_dims).OR.PRESENT(len_dims)) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v, & + & ndims=n_w,dimids=dim_ids) + IF (PRESENT(nb_dims)) THEN + nb_dims = n_w + ENDIF + IF (PRESENT(len_dims)) THEN + i_s = SIZE(len_dims) + len_dims(:) = -1 + IF (i_s < n_w) THEN + CALL ipslerr (2,'flioinqv', & + & 'Only the first dimensions of the variable', & + & TRIM(v_n),'will be returned') + ENDIF + DO i_w=1,MIN(n_w,i_s) + i_rc = NF90_INQUIRE_DIMENSION(f_e,dim_ids(i_w), & + & len=len_dims(i_w)) + ENDDO + ENDIF + IF (PRESENT(id_dims)) THEN + i_s = SIZE(id_dims) + id_dims(:) = -1 + IF (i_s < n_w) THEN + CALL ipslerr (2,'flioinqv', & + & 'The number of dimensions to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first dimensions of "' & + & //TRIM(v_n)//'" will be returned') + ENDIF + i_w = MIN(n_w,i_s) + id_dims(1:i_w) = dim_ids(1:i_w) + ENDIF + ENDIF + IF (PRESENT(nb_atts).OR.PRESENT(cn_atts)) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,nAtts=n_w) + IF (PRESENT(nb_atts)) THEN + nb_atts = n_w + ENDIF + IF (PRESENT(cn_atts)) THEN + l_ok = .TRUE. + i_s = SIZE(cn_atts) + DO i_w=1,i_s + cn_atts(i_w)(:) = '?' + ENDDO + IF (PRESENT(ia_start)) THEN + iws = ia_start + ELSE + iws = 1 + ENDIF + IF (PRESENT(ia_count)) THEN + iwc = ia_count + ELSE + iwc = n_w + ENDIF + IF (iws > n_w) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqv', & + & 'The start index of requested attributes', & + & 'is greater than the number of attributes of', & + & '"'//TRIM(v_n)//'"') + ELSE IF (iws < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqv', & + & 'The start index of requested attributes', & + & 'is invalid ( < 1 ) for', & + & '"'//TRIM(v_n)//'"') + ENDIF + IF ((iws+iwc-1) > n_w) THEN + CALL ipslerr (2,'flioinqv', & + & 'The number of requested attributes', & + & 'is greater than the number of attributes of', & + & '"'//TRIM(v_n)//'"') + ENDIF + IF (iwc > i_s) THEN + CALL ipslerr (2,'flioinqv', & + & 'The number of attributes to retrieve', & + & 'is greater than the size of the array,', & + & 'only the first attributes of "' & + & //TRIM(v_n)//'" will be returned') + ELSE IF (iwc < 1) THEN + l_ok = .FALSE. + CALL ipslerr (2,'flioinqv', & + & 'The number of requested attributes', & + & 'is invalid ( < 1 ) for', & + & '"'//TRIM(v_n)//'"') + ENDIF + IF (l_ok) THEN + DO i_w=1,MIN(iwc,i_s,n_w-iws+1) + i_rc = NF90_INQ_ATTNAME(f_e, & + & i_v,i_w+iws-1,name=cn_atts(i_w)) + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqv" + ENDIF +!---------------------- +END SUBROUTINE flioinqv +!=== +SUBROUTINE fliogv_i40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_i40 +!=== +SUBROUTINE fliogv_i41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i41 +!=== +SUBROUTINE fliogv_i42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i42 +!=== +SUBROUTINE fliogv_i43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i43 +!=== +SUBROUTINE fliogv_i44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i44 +!=== +SUBROUTINE fliogv_i45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i45 +!=== +SUBROUTINE fliogv_i20 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_20=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_i20 +!=== +SUBROUTINE fliogv_i21 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_21=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i21 +!=== +SUBROUTINE fliogv_i22 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_22=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i22 +!=== +SUBROUTINE fliogv_i23 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_23=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i23 +!=== +SUBROUTINE fliogv_i24 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_24=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i24 +!=== +SUBROUTINE fliogv_i25 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,i_25=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_i25 +!=== +!?INTEGERS of KIND 1 are not supported on all computers +!?SUBROUTINE fliogv_i10 (f_i,v_n,v_v,start) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_10=v_v,start=start) +!?!------------------------ +!?END SUBROUTINE fliogv_i10 +!?!=== +!?SUBROUTINE fliogv_i11 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_11=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i11 +!?!=== +!?SUBROUTINE fliogv_i12 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_12=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i12 +!?!=== +!?SUBROUTINE fliogv_i13 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_13=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i13 +!?!=== +!?SUBROUTINE fliogv_i14 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_14=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i14 +!?!=== +!?SUBROUTINE fliogv_i15 (f_i,v_n,v_v,start,count) +!?!--------------------------------------------------------------------- +!? IMPLICIT NONE +!?!- +!? INTEGER,INTENT(IN) :: f_i +!? CHARACTER(LEN=*),INTENT(IN) :: v_n +!? INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v +!? INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!?!--------------------------------------------------------------------- +!? CALL flio_ugv (f_i,v_n,i_15=v_v,start=start,count=count) +!?!------------------------ +!?END SUBROUTINE fliogv_i15 +!=== +SUBROUTINE fliogv_r40 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_40=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_r40 +!=== +SUBROUTINE fliogv_r41 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_41=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r41 +!=== +SUBROUTINE fliogv_r42 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_42=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r42 +!=== +SUBROUTINE fliogv_r43 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_43=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r43 +!=== +SUBROUTINE fliogv_r44 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_44=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r44 +!=== +SUBROUTINE fliogv_r45 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_45=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r45 +!=== +SUBROUTINE fliogv_r80 (f_i,v_n,v_v,start) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_80=v_v,start=start) +!------------------------ +END SUBROUTINE fliogv_r80 +!=== +SUBROUTINE fliogv_r81 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_81=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r81 +!=== +SUBROUTINE fliogv_r82 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_82=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r82 +!=== +SUBROUTINE fliogv_r83 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_83=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r83 +!=== +SUBROUTINE fliogv_r84 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_84=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r84 +!=== +SUBROUTINE fliogv_r85 (f_i,v_n,v_v,start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v + INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count +!--------------------------------------------------------------------- + CALL flio_ugv (f_i,v_n,r_85=v_v,start=start,count=count) +!------------------------ +END SUBROUTINE fliogv_r85 +!=== +SUBROUTINE flio_ugv & + & (f_i,v_n, & + & i_40,i_41,i_42,i_43,i_44,i_45, & + & i_20,i_21,i_22,i_23,i_24,i_25, & +!? & i_10,i_11,i_12,i_13,i_14,i_15, & + & r_40,r_41,r_42,r_43,r_44,r_45, & + & r_80,r_81,r_82,r_83,r_84,r_85, & + & start,count) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n + INTEGER(KIND=i_4),INTENT(OUT),OPTIONAL :: i_40 + INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_41 + INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_42 + INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_43 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_44 + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_45 + INTEGER(KIND=i_2),INTENT(OUT),OPTIONAL :: i_20 + INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_21 + INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_22 + INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_23 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_24 + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_25 +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER(KIND=i_1),INTENT(OUT),OPTIONAL :: i_10 +!?INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_11 +!?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_12 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_13 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_14 +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_15 + REAL(KIND=r_4),INTENT(OUT),OPTIONAL :: r_40 + REAL(KIND=r_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_41 + REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_42 + REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_43 + REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_44 + REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_45 + REAL(KIND=r_8),INTENT(OUT),OPTIONAL :: r_80 + REAL(KIND=r_8),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_81 + REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_82 + REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_83 + REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_84 + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_85 + INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count +!- + INTEGER :: f_e,i_v,i_rc + CHARACTER(LEN=5) :: cvr_d +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + IF (PRESENT(i_40)) THEN; cvr_d = "I1 0D"; + ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D"; + ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D"; + ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D"; + ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D"; + ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D"; + ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D"; + ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D"; + ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D"; + ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D"; + ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D"; + ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D"; +!? ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D"; +!? ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D"; +!? ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D"; +!? ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D"; +!? ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D"; +!? ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D"; + ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D"; + ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D"; + ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D"; + ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D"; + ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D"; + ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D"; + ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D"; + ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D"; + ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D"; + ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D"; + ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D"; + ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D"; + ENDIF + WRITE(*,*) "->fliogetv ",TRIM(v_n)," ",TRIM(cvr_d) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliogetv',f_i,f_e) +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc == NF90_NOERR) THEN + IF (PRESENT(i_40)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_40,start=start) + ELSE IF (PRESENT(i_41)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_41,start=start,count=count) + ELSE IF (PRESENT(i_42)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_42,start=start,count=count) + ELSE IF (PRESENT(i_43)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_43,start=start,count=count) + ELSE IF (PRESENT(i_44)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_44,start=start,count=count) + ELSE IF (PRESENT(i_45)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_45,start=start,count=count) + ELSE IF (PRESENT(i_20)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_20,start=start) + ELSE IF (PRESENT(i_21)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_21,start=start,count=count) + ELSE IF (PRESENT(i_22)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_22,start=start,count=count) + ELSE IF (PRESENT(i_23)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_23,start=start,count=count) + ELSE IF (PRESENT(i_24)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_24,start=start,count=count) + ELSE IF (PRESENT(i_25)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,i_25,start=start,count=count) +!? ELSE IF (PRESENT(i_10)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_10,start=start) +!? ELSE IF (PRESENT(i_11)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_11,start=start,count=count) +!? ELSE IF (PRESENT(i_12)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_12,start=start,count=count) +!? ELSE IF (PRESENT(i_13)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_13,start=start,count=count) +!? ELSE IF (PRESENT(i_14)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_14,start=start,count=count) +!? ELSE IF (PRESENT(i_15)) THEN +!? i_rc = NF90_GET_VAR(f_e,i_v,i_15,start=start,count=count) + ELSE IF (PRESENT(r_40)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_40,start=start) + ELSE IF (PRESENT(r_41)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_41,start=start,count=count) + ELSE IF (PRESENT(r_42)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_42,start=start,count=count) + ELSE IF (PRESENT(r_43)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_43,start=start,count=count) + ELSE IF (PRESENT(r_44)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_44,start=start,count=count) + ELSE IF (PRESENT(r_45)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_45,start=start,count=count) + ELSE IF (PRESENT(r_80)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_80,start=start) + ELSE IF (PRESENT(r_81)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_81,start=start,count=count) + ELSE IF (PRESENT(r_82)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_82,start=start,count=count) + ELSE IF (PRESENT(r_83)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_83,start=start,count=count) + ELSE IF (PRESENT(r_84)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_84,start=start,count=count) + ELSE IF (PRESENT(r_85)) THEN + i_rc = NF90_GET_VAR(f_e,i_v,r_85,start=start,count=count) + ENDIF + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogetv', & + & 'Variable '//TRIM(v_n)//' not get','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + ELSE + CALL ipslerr (3,'fliogetv','Variable',TRIM(v_n),'not found') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliogetv" + ENDIF +!---------------------- +END SUBROUTINE flio_ugv +!=== +SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + LOGICAL,INTENT(OUT) :: l_ex + INTEGER,OPTIONAL,INTENT(OUT) :: a_t,a_l +!- + INTEGER :: i_rc,f_e,i_v,t_ea,l_ea +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioinqa ",TRIM(v_n),"-",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioinqa',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flioinqa', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea) +!- + l_ex = (i_rc == NF90_NOERR) +!- + IF (l_ex) THEN + IF (PRESENT(a_t)) THEN + a_t = t_ea + ENDIF + IF (PRESENT(a_l)) THEN + a_l = l_ea + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioinqa" + ENDIF +!---------------------- +END SUBROUTINE flioinqa +!=== +SUBROUTINE flioga_r4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_4_0=a_v) +!--------------------------- +END SUBROUTINE flioga_r4_0d +!=== +SUBROUTINE flioga_r4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_4_1=a_v) +!-------------------------- +END SUBROUTINE flioga_r4_1d +!=== +SUBROUTINE flioga_r8_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_8_0=a_v) +!--------------------------- +END SUBROUTINE flioga_r8_0d +!=== +SUBROUTINE flioga_r8_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=8),DIMENSION(:),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avr_8_1=a_v) +!-------------------------- +END SUBROUTINE flioga_r8_1d +!=== +SUBROUTINE flioga_i4_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avi_4_0=a_v) +!--------------------------- +END SUBROUTINE flioga_i4_0d +!=== +SUBROUTINE flioga_i4_1d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + INTEGER(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avi_4_1=a_v) +!-------------------------- +END SUBROUTINE flioga_i4_1d +!=== +SUBROUTINE flioga_tx_0d (f_i,v_n,a_n,a_v) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + CHARACTER(LEN=*),INTENT(OUT) :: a_v +!--------------------------------------------------------------------- + CALL flio_uga (f_i,v_n,a_n,avtx=a_v) +!--------------------------- +END SUBROUTINE flioga_tx_0d +!=== +SUBROUTINE flio_uga & + & (f_i,v_n,a_n, & + & avr_4_0,avr_4_1,avr_8_0,avr_8_1,avi_4_0,avi_4_1,avtx) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n + REAL(KIND=4),OPTIONAL,INTENT(OUT) :: avr_4_0 + REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_4_1 + REAL(KIND=8),OPTIONAL,INTENT(OUT) :: avr_8_0 + REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_8_1 + INTEGER(KIND=4),OPTIONAL,INTENT(OUT) :: avi_4_0 + INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avi_4_1 + CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: avtx +!- + INTEGER :: f_e,l_ua,i_v,t_ea,l_ea,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliogeta ",TRIM(v_n)," ",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliogeta',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogeta', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliogeta', & + & 'Attribute :',TRIM(a_n),'not found') + ENDIF +!- + IF ( (.NOT.PRESENT(avtx).AND.(t_ea == NF90_CHAR)) & + & .OR.(PRESENT(avtx).AND.(t_ea /= NF90_CHAR)) ) THEN + CALL ipslerr (3,'fliogeta', & + & 'The external type of the attribute :',TRIM(a_n), & + & 'is not compatible with the type of the argument') + ENDIF +!- + IF (PRESENT(avr_4_1)) THEN + l_ua = SIZE(avr_4_1) + ELSE IF (PRESENT(avr_8_1)) THEN + l_ua = SIZE(avr_8_1) + ELSE IF (PRESENT(avi_4_1)) THEN + l_ua = SIZE(avi_4_1) + ELSE IF (PRESENT(avtx)) THEN + l_ua = LEN(avtx) + ELSE + l_ua = 1 + ENDIF +!- + IF (l_ua < l_ea) THEN + CALL ipslerr (3,'fliogeta', & + 'Insufficient size of the argument', & + & 'to receive the values of the attribute :',TRIM(a_n)) + ENDIF +!- + IF (PRESENT(avr_4_0)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_0) + ELSE IF (PRESENT(avr_4_1)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_1(1:l_ea)) + ELSE IF (PRESENT(avr_8_0)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_0) + ELSE IF (PRESENT(avr_8_1)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_1(1:l_ea)) + ELSE IF (PRESENT(avi_4_0)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_0) + ELSE IF (PRESENT(avi_4_1)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_1(1:l_ea)) + ELSE IF (PRESENT(avtx)) THEN + i_rc = NF90_GET_ATT(f_e,i_v,a_n,avtx) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliogeta" + ENDIF +!---------------------- +END SUBROUTINE flio_uga +!=== +SUBROUTINE fliorenv (f_i,v_o_n,v_n_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_o_n,v_n_n +!- + INTEGER :: f_e,i_v,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) & + & "->fliorenv ",TRIM(v_o_n),"->",TRIM(v_n_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliorenv',f_i,f_e) +!- + i_rc = NF90_INQ_VARID(f_e,v_o_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorenv', & + 'Variable :',TRIM(v_o_n),'not found') + ELSE + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_RENAME_VAR(f_e,i_v,v_n_n) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorenv', & + 'Variable :',TRIM(v_o_n),'can not be renamed') + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliorenv" + ENDIF +!---------------------- +END SUBROUTINE fliorenv +!=== +SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_o_n,a_n_n +!- + INTEGER :: f_e,i_v,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) & + & "->fliorena ",TRIM(v_n),"-",TRIM(a_o_n),"->",TRIM(a_n_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliorena',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliorena', & + 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_o_n,attnum=i_a) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorena', & + 'Attribute :',TRIM(a_o_n),'not found') + ELSE + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_RENAME_ATT(f_e,i_v,a_o_n,a_n_n) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliorena', & + 'Attribute :',TRIM(a_o_n),'can not be renamed') + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliorena" + ENDIF +!---------------------- +END SUBROUTINE fliorena +!=== +SUBROUTINE fliodela (f_i,v_n,a_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n +!- + INTEGER :: f_e,i_v,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliodela ",TRIM(v_n),"-",TRIM(a_n) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliodela',f_i,f_e) +!- + IF (TRIM(v_n) == '?') THEN + i_v = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e,v_n,i_v) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliodela', & + & 'Variable :',TRIM(v_n),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (2,'fliodela', & + & 'Attribute :',TRIM(a_n),'not found') + ELSE + IF (i_v == NF90_GLOBAL) THEN + nw_na(f_i) = nw_na(f_i)-1 + ENDIF + CALL flio_hdm (f_i,f_e,.TRUE.) + i_rc = NF90_DEL_ATT(f_e,i_v,a_n) + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliodela" + ENDIF +!---------------------- +END SUBROUTINE fliodela +!=== +SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i_i,f_i_o + CHARACTER(LEN=*),INTENT(IN) :: v_n_i,a_n,v_n_o +!- + INTEGER :: f_e_i,f_e_o,i_v_i,i_v_o,i_a,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliocpya - file",f_i_i,"-",TRIM(v_n_i),"-",TRIM(a_n) + WRITE(*,*) " copied to file ",f_i_o,"-",TRIM(v_n_o) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('fliocpya',f_i_i,f_e_i) + CALL flio_qvid ('fliocpya',f_i_o,f_e_o) +!- + IF (TRIM(v_n_i) == '?') THEN + i_v_i = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e_i,v_n_i,i_v_i) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + & 'Variable :',TRIM(v_n_i),'not found') + ENDIF + ENDIF +!- + IF (TRIM(v_n_o) == '?') THEN + i_v_o = NF90_GLOBAL + ELSE + i_rc = NF90_INQ_VARID(f_e_o,v_n_o,i_v_o) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + & 'Variable :',TRIM(v_n_o),'not found') + ENDIF + ENDIF +!- + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_i,i_v_i,a_n,attnum=i_a) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + 'Attribute :',TRIM(a_n),'not found') + ELSE + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_o,i_v_o,a_n,attnum=i_a) + IF ( (i_v_o == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN + nw_na(f_i_o) = nw_na(f_i_o)+1 + ENDIF + CALL flio_hdm (f_i_o,f_e_o,.TRUE.) + i_rc = NF90_COPY_ATT(f_e_i,i_v_i,a_n,f_e_o,i_v_o) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliocpya', & + & 'Attribute '//TRIM(a_n)//' not copied','Error :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliocpya" + ENDIF +!---------------------- +END SUBROUTINE fliocpya +!=== +SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i + CHARACTER(LEN=*),INTENT(IN) :: c_type + LOGICAL,INTENT(OUT) :: l_ex + CHARACTER(LEN=*),INTENT(OUT) :: c_name +!- + CHARACTER(LEN=1) :: c_ax + INTEGER :: f_e,idc,ndc,i_rc +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioqstc ",TRIM(c_type) + ENDIF +!- +! Retrieve the external file index + CALL flio_qvid ('flioqstc',f_i,f_e) +!- + c_ax = TRIM(c_type) + IF ( (LEN_TRIM(c_type) == 1) & + & .AND.( (c_ax == 'x').OR.(c_ax == 'y') & + & .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN + CALL flio_qax (f_i,c_ax,idc,ndc) + l_ex = (idc > 0) + IF (l_ex) THEN + i_rc = NF90_INQUIRE_VARIABLE(f_e,idc,name=c_name) + ENDIF + ELSE + l_ex = .FALSE. + CALL ipslerr (2,'flioqstc', & + & 'The name of the coordinate,',TRIM(c_type),'is not valid') + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioqstc" + ENDIF +!---------------------- +END SUBROUTINE flioqstc +!=== +SUBROUTINE fliosync (f_i) +!--------------------------------------------------------------------- + INTEGER,INTENT(in),OPTIONAL :: f_i +!- + INTEGER :: i_f,f_e,i_rc,i_s,i_e +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->fliosync" + ENDIF +!- + IF (PRESENT(f_i)) THEN + IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN + i_s = f_i + i_e = f_i + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'fliosync', & + & 'Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_fi_mx + ENDIF +!- +! Ensuring data mode +!- + CALL flio_hdm (f_i,f_e,.FALSE.) +!- + DO i_f=i_s,i_e + f_e = nw_id(i_f) + IF (f_e > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' fliosync - synchronising file number ',i_f + ENDIF + i_rc = NF90_SYNC(f_e) + ELSE IF (PRESENT(f_i)) THEN + CALL ipslerr (2,'fliosync', & + & 'Unable to synchronise the file :','probably','not opened') + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-fliosync" + ENDIF +!---------------------- +END SUBROUTINE fliosync +!=== +SUBROUTINE flioclo (f_i) +!--------------------------------------------------------------------- + INTEGER,INTENT(in),OPTIONAL :: f_i +!- + INTEGER :: i_f,f_e,i_rc,i_s,i_e +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flioclo" + ENDIF +!- + IF (PRESENT(f_i)) THEN + IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN + i_s = f_i + i_e = f_i + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'flioclo', & + & 'Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_fi_mx + ENDIF +!- + DO i_f=i_s,i_e + f_e = nw_id(i_f) + IF (f_e > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' flioclo - closing file number ',i_f + ENDIF + i_rc = NF90_CLOSE(f_e) + nw_id(i_f) = -1 + ELSE IF (PRESENT(f_i)) THEN + CALL ipslerr (2,'flioclo', & + & 'Unable to close the file :','probably','not opened') + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flioclo" + ENDIF +!--------------------- +END SUBROUTINE flioclo +!=== +SUBROUTINE fliodmpf (f_n) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: f_n +!- + INTEGER :: f_e,n_dims,n_vars,n_atts,i_unlm + INTEGER :: i_rc,i_n,k_n,t_ea,l_ea + INTEGER :: tmp_i + REAL :: tmp_r + INTEGER,DIMENSION(:),ALLOCATABLE :: tma_i + REAL,DIMENSION(:),ALLOCATABLE :: tma_r + CHARACTER(LEN=256) :: tmp_c + INTEGER,DIMENSION(nb_fd_mx) :: n_idim,n_ldim + INTEGER,DIMENSION(nb_ax_mx) :: n_ai + CHARACTER(LEN=NF90_MAX_NAME),DIMENSION(nb_fd_mx) :: c_ndim + INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid + CHARACTER(LEN=NF90_MAX_NAME) :: c_name +!--------------------------------------------------------------------- + i_rc = NF90_OPEN(TRIM(f_n),NF90_NOWRITE,f_e) + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'fliodmpf', & + & 'Could not open file :',TRIM(f_n), & + & TRIM(NF90_STRERROR(i_rc))//' (Netcdf)') + ENDIF +!- + WRITE (*,*) "---" + WRITE (*,*) "--- File '",TRIM(f_n),"'" + WRITE (*,*) "---" +!- + CALL flio_inf & + & (f_e,nb_dims=n_dims,nb_vars=n_vars, & + & nb_atts=n_atts,id_unlm=i_unlm, & + & nn_idm=n_idim,nn_ldm=n_ldim,cc_ndm=c_ndim,nn_aid=n_ai) +!- + WRITE (*,*) 'External model identifier : ',f_e + WRITE (*,*) 'Number of dimensions : ',n_dims + WRITE (*,*) 'Number of variables : ',n_vars + WRITE (*,*) 'ID unlimited : ',i_unlm +!- + WRITE (*,*) "---" + WRITE (*,*) 'Presumed axis dimensions identifiers :' + IF (n_ai(k_lon) > 0) THEN + WRITE (*,*) 'x axis : ',n_ai(k_lon) + ELSE + WRITE (*,*) 'x axis : NONE' + ENDIF + IF (n_ai(k_lat) > 0) THEN + WRITE (*,*) 'y axis : ',n_ai(k_lat) + ELSE + WRITE (*,*) 'y axis : NONE' + ENDIF + IF (n_ai(k_lev) > 0) THEN + WRITE (*,*) 'z axis : ',n_ai(k_lev) + ELSE + WRITE (*,*) 'z axis : NONE' + ENDIF + IF (n_ai(k_tim) > 0) THEN + WRITE (*,*) 't axis : ',n_ai(k_tim) + ELSE + WRITE (*,*) 't axis : NONE' + ENDIF +!- + WRITE (*,*) "---" + WRITE (*,*) 'Number of global attributes : ',n_atts + DO k_n=1,n_atts + i_rc = NF90_INQ_ATTNAME(f_e,NF90_GLOBAL,k_n,c_name) + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,NF90_GLOBAL,c_name, & + & xtype=t_ea,len=l_ea) + IF ( (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) & + .OR.(t_ea == NF90_INT1) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_i(l_ea)) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_i) + WRITE (*,'(" ",A," :",/,(5(1X,I10),:))') & + & TRIM(c_name),tma_i(1:l_ea) + DEALLOCATE(tma_i) + ELSE + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_i) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_i + ENDIF + ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_r(l_ea)) + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_r) + WRITE (*,'(" ",A," :",/,(5(1X,1PE11.3),:))') & + & TRIM(c_name),tma_r(1:l_ea) + DEALLOCATE(tma_r) + ELSE + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_r) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_r + ENDIF + ELSE + tmp_c = '' + i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_c) + WRITE(*,*) ' ',TRIM(c_name),' : "',TRIM(tmp_c),'"' + ENDIF + ENDDO +!- + DO i_n=1,nb_fd_mx + IF (n_idim(i_n) > 0) THEN + WRITE (*,*) "---" + WRITE (*,*) 'Dimension id : ',n_idim(i_n) + WRITE (*,*) 'Dimension name : ',TRIM(c_ndim(i_n)) + WRITE (*,*) 'Dimension size : ',n_ldim(i_n) + ENDIF + ENDDO +!- + DO i_n=1,n_vars + i_rc = NF90_INQUIRE_VARIABLE(f_e,i_n, & + & name=c_name,ndims=n_dims,dimids=idimid,nAtts=n_atts) + WRITE (*,*) "---" + WRITE (*,*) "Variable name : ",TRIM(c_name) + WRITE (*,*) "Variable identifier : ",i_n + WRITE (*,*) "Number of dimensions : ",n_dims + IF (n_dims > 0) THEN + WRITE (*,*) "Dimensions ID's : ",idimid(1:n_dims) + ENDIF + WRITE (*,*) "Number of attributes : ",n_atts + DO k_n=1,n_atts + i_rc = NF90_INQ_ATTNAME(f_e,i_n,k_n,c_name) + i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_n,c_name, & + & xtype=t_ea,len=l_ea) + IF ( (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) & + & .OR.(t_ea == NF90_INT1) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_i(l_ea)) + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_i) + WRITE (*,'(" ",A," :",/,(5(1X,I10),:))') & + & TRIM(c_name),tma_i(1:l_ea) + DEALLOCATE(tma_i) + ELSE + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_i) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_i + ENDIF + ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN + IF (l_ea > 1) THEN + ALLOCATE(tma_r(l_ea)) + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_r) + WRITE (*,'(" ",A," :",/,(5(1X,1PE11.3),:))') & + & TRIM(c_name),tma_r(1:l_ea) + DEALLOCATE(tma_r) + ELSE + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_r) + WRITE(*,*) ' ',TRIM(c_name),' : ',tmp_r + ENDIF + ELSE + tmp_c = '' + i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_c) + WRITE(*,*) ' ',TRIM(c_name),' : "',TRIM(tmp_c),'"' + ENDIF + ENDDO + ENDDO + WRITE (*,*) "---" +!- + i_rc = NF90_CLOSE(f_e) +!---------------------- +END SUBROUTINE fliodmpf +!=== +SUBROUTINE flio_dom_set & + & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: dtnb,dnb + INTEGER,DIMENSION(:),INTENT(IN) :: did,dsg,dsl,dpf,dpl,dhs,dhe + CHARACTER(LEN=*),INTENT(IN) :: cdnm + INTEGER,INTENT(OUT) :: id_dom +!- + INTEGER :: k_w,i_w,i_s + CHARACTER(LEN=l_dns) :: cd_p,cd_w +!--------------------------------------------------------------------- + k_w = flio_dom_rid() + IF (k_w < 0) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'too many domains simultaneously defined', & + & 'please unset useless domains', & + & 'by calling flio_dom_unset') + ENDIF + id_dom = k_w +!- + d_n_t(k_w) = dtnb + d_n_c(k_w) = dnb +!- + i_s = SIZE(did) + IF (i_s > dom_max_dims) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'too many distributed dimensions', & + & 'simultaneously defined',' ') + ENDIF + d_d_n(k_w) = i_s + d_d_i(1:i_s,k_w) = did(1:i_s) +!- + i_w = SIZE(dsg) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_size_global array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_s_g(1:i_w,k_w) = dsg(1:i_w) +!- + i_w = SIZE(dsl) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_size_local array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_s_l(1:i_w,k_w) = dsl(1:i_w) +!- + i_w = SIZE(dpf) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_position_first array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_p_f(1:i_w,k_w) = dpf(1:i_w) +!- + i_w = SIZE(dpl) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_position_last array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_p_l(1:i_w,k_w) = dpl(1:i_w) +!- + i_w = SIZE(dhs) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_halo_size_start array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_h_s(1:i_w,k_w) = dhs(1:i_w) +!- + i_w = SIZE(dhe) + IF (i_w /= i_s) THEN + CALL ipslerr (3,'flio_dom_set', & + & 'the size of the DOMAIN_halo_size_end array', & + & 'is not equal to the size', & + & 'of the distributed dimensions array') + ENDIF + d_h_e(1:i_w,k_w) = dhe(1:i_w) +!- + cd_p = "unknown" + cd_w = cdnm; CALL strlowercase (cd_w) + DO i_w=1,n_dns + IF (TRIM(cd_w) == TRIM(c_dns(i_w))) THEN + cd_p = cd_w; EXIT; + ENDIF + ENDDO + IF (TRIM(cd_p) == "unknown") THEN + CALL ipslerr (3,'flio_dom_set', & + & 'DOMAIN_type "'//TRIM(cdnm)//'"', & + & 'is actually not supported', & + & 'please use one of the supported names') + ENDIF + c_d_t(k_w) = cd_p +!-------------------------- +END SUBROUTINE flio_dom_set +!=== +SUBROUTINE flio_dom_unset (id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN),OPTIONAL :: id_dom +!- + INTEGER :: i_w +!--------------------------------------------------------------------- + IF (PRESENT(id_dom)) THEN + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + IF (d_d_n(id_dom) > 0) THEN + d_d_n(id_dom) = -1 + ELSE + CALL ipslerr (2,'flio_dom_unset', & + & 'The domain is not set',' ',' ') + ENDIF + ELSE + CALL ipslerr (2,'flio_dom_unset', & + & 'Invalid file identifier',' ',' ') + ENDIF + ELSE + DO i_w=1,dom_max_nb + d_d_n(id_dom) = -1 + ENDDO + ENDIF +!---------------------------- +END SUBROUTINE flio_dom_unset +!=== +SUBROUTINE flio_dom_defset (id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: id_dom +!--------------------------------------------------------------------- + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + id_def_dom = id_dom + ELSE + CALL ipslerr (3,'flio_dom_defset', & + & 'Invalid domain identifier',' ',' ') + ENDIF +!----------------------------- +END SUBROUTINE flio_dom_defset +!=== +SUBROUTINE flio_dom_defunset () +!--------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------- + id_def_dom = FLIO_DOM_NONE +!------------------------------- +END SUBROUTINE flio_dom_defunset +!=== +SUBROUTINE flio_dom_definq (id_dom) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: id_dom +!--------------------------------------------------------------------- + id_dom = id_def_dom +!----------------------------- +END SUBROUTINE flio_dom_definq +!=== +!- +!--------------------------------------------------------------------- +!- Semi-public procedures +!--------------------------------------------------------------------- +!- +!=== +SUBROUTINE flio_dom_file (f_n,id_dom) +!--------------------------------------------------------------------- +!- Update the model file name to include the ".nc" suffix and +!- the DOMAIN number on which this copy of IOIPSL runs, if needed. +!- This routine is called by IOIPSL and not by user anyway. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(INOUT) :: f_n + INTEGER,OPTIONAL,INTENT(IN) :: id_dom +!- + INTEGER :: il,iw + CHARACTER(LEN=4) :: str +!--------------------------------------------------------------------- +!- +! Add the ".nc" suffix if needed + il = LEN_TRIM(f_n) + IF (f_n(il-2:il) /= '.nc') THEN + f_n = f_n(1:il)//'.nc' + ENDIF +!- +! Add the DOMAIN identifier if needed + IF (PRESENT(id_dom)) THEN + IF (id_dom == FLIO_DOM_DEFAULT) THEN + CALL flio_dom_definq (iw) + ELSE + iw = id_dom + ENDIF + IF (iw /= FLIO_DOM_NONE) THEN + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + IF (d_d_n(iw) > 0) THEN + WRITE(str,'(I4.4)') d_n_c(iw) + il = INDEX(f_n,'.nc') + f_n = f_n(1:il-1)//'_'//str//'.nc' + ELSE + CALL ipslerr (3,'flio_dom_file', & + & 'The domain has not been defined', & + & 'please call flio_dom_set', & + & 'before calling flio_dom_file') + ENDIF + ELSE + CALL ipslerr (3,'flio_dom_file', & + & 'Invalid domain identifier',' ',' ') + ENDIF + ENDIF + ENDIF +!--------------------------- +END SUBROUTINE flio_dom_file +!=== +SUBROUTINE flio_dom_att (f_e,id_dom) +!--------------------------------------------------------------------- +!- Add the DOMAIN attributes to the NETCDF file. +!- This routine is called by IOIPSL and not by user anyway. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: f_e + INTEGER,OPTIONAL,INTENT(IN) :: id_dom +!- + INTEGER :: iw,i_rc,i_n + CHARACTER(LEN=15) :: c_ddim + INTEGER :: n_idim + CHARACTER(LEN=NF90_MAX_NAME) :: c_ndim +!--------------------------------------------------------------------- + IF (PRESENT(id_dom)) THEN + IF (id_dom == FLIO_DOM_DEFAULT) THEN + CALL flio_dom_definq (iw) + ELSE + iw = id_dom + ENDIF + IF (iw /= FLIO_DOM_NONE) THEN + IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN + IF (d_d_n(iw) > 0) THEN + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_number_total',d_n_t(iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_number',d_n_c(iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_dimensions_ids',d_d_i(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_size_global',d_s_g(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_size_local',d_s_l(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_position_first',d_p_f(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_position_last',d_p_l(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_halo_size_start',d_h_s(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_halo_size_end',d_h_e(1:d_d_n(iw),iw)) + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, & + & 'DOMAIN_type',TRIM(c_d_t(iw))) + i_rc = NF90_INQUIRE (f_e,nDimensions=n_idim) + DO i_n=1,n_idim + i_rc = NF90_INQUIRE_DIMENSION (f_e,i_n,name=c_ndim) + WRITE (UNIT=c_ddim,FMT='("DOMAIN_DIM_N",I3.3)') i_n + i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL,c_ddim,TRIM(c_ndim)) + ENDDO + ELSE + CALL ipslerr (3,'flio_dom_att', & + & 'The domain has not been defined', & + & 'please call flio_dom_set', & + & 'before calling flio_dom_att') + ENDIF + ELSE + CALL ipslerr (3,'flio_dom_att', & + & 'Invalid domain identifier',' ',' ') + ENDIF + ENDIF + ENDIF +!-------------------------- +END SUBROUTINE flio_dom_att +!=== +!- +!--------------------------------------------------------------------- +!- Local procedures +!--------------------------------------------------------------------- +!- +!=== +INTEGER FUNCTION flio_rid() +!--------------------------------------------------------------------- +!- returns a free index in nw_id(:) +!--------------------------------------------------------------------- + INTEGER,DIMENSION(1:1) :: nfi +!- + IF (ANY(nw_id < 0)) THEN + nfi = MINLOC(nw_id,MASK=nw_id < 0) + flio_rid = nfi(1) + ELSE + flio_rid = -1 + ENDIF +!-------------------- +END FUNCTION flio_rid +!=== +INTEGER FUNCTION flio_dom_rid() +!--------------------------------------------------------------------- +!- returns a free index in d_d_n(:) +!--------------------------------------------------------------------- + INTEGER,DIMENSION(1:1) :: nd +!--------------------------------------------------------------------- + IF (ANY(d_d_n < 0)) THEN + nd = MINLOC(d_d_n,MASK=d_d_n < 0) + flio_dom_rid = nd(1) + ELSE + flio_dom_rid = -1 + ENDIF +!------------------------ +END FUNCTION flio_dom_rid +!=== +INTEGER FUNCTION flio_qid(iid) +!--------------------------------------------------------------------- +!- returns the external index associated with the internal index "iid" +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: iid +!--------------------------------------------------------------------- + IF ( (iid >= 1).AND.(iid <= nb_fi_mx) ) THEN + flio_qid = nw_id(iid) + ELSE + flio_qid = -1 + ENDIF +!-------------------- +END FUNCTION flio_qid +!=== +SUBROUTINE flio_qvid (cpg,iid,ixd) +!--------------------------------------------------------------------- +!- This subroutine, called by the procedure "cpg", +!- validates and returns the external file index "ixd" +!- associated with the internal file index "iid" +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: cpg + INTEGER,INTENT(IN) :: iid + INTEGER,INTENT(OUT) :: ixd +!- + CHARACTER(LEN=20) :: c_t +!--------------------------------------------------------------------- + ixd = flio_qid(iid) + IF (ixd < 0) THEN + WRITE (UNIT=c_t,FMT='(I15)') iid + CALL ipslerr (3,TRIM(cpg), & + & 'Invalid internal file index :',TRIM(ADJUSTL(c_t)),' ') + ENDIF +!----------------------- +END SUBROUTINE flio_qvid +!=== +SUBROUTINE flio_hdm (f_i,f_e,lk_hm) +!--------------------------------------------------------------------- +!- This subroutine handles the "define/data mode" of NETCDF. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_i,f_e + LOGICAL,INTENT(IN) :: lk_hm +!- + INTEGER :: i_rc +!--------------------------------------------------------------------- + i_rc = NF90_NOERR +!- + IF ( (.NOT.lw_hm(f_i)).AND.(lk_hm) ) THEN + i_rc = NF90_REDEF(f_e) + lw_hm(f_i) = .TRUE. + ELSE IF ( (lw_hm(f_i)).AND.(.NOT.lk_hm) ) THEN + i_rc = NF90_ENDDEF(f_e) + lw_hm(f_i) = .FALSE. + ENDIF +!- + IF (i_rc /= NF90_NOERR) THEN + CALL ipslerr (3,'flio_hdm', & + & 'Internal error ','in define/data mode :', & + & TRIM(NF90_STRERROR(i_rc))) + ENDIF +!---------------------- +END SUBROUTINE flio_hdm +!=== +SUBROUTINE flio_inf (f_e, & + & nb_dims,nb_vars,nb_atts,id_unlm,nn_idm,nn_ldm,nn_aid,cc_ndm) +!--------------------------------------------------------------------- +!- This subroutine allows to get some information concerning +!- the model file whose the external identifier is "f_e". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: f_e + INTEGER,OPTIONAL,INTENT(OUT) :: nb_dims,nb_vars,nb_atts,id_unlm + INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: nn_idm,nn_ldm,nn_aid + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cc_ndm +!- + INTEGER :: nm_dims,nm_vars,nm_atts,nm_unlm,ml + INTEGER :: i_rc,kv + CHARACTER(LEN=NF90_MAX_NAME) :: f_d_n +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->flio_inf" + ENDIF +!- + i_rc = NF90_INQUIRE(f_e,nDimensions=nm_dims,nVariables=nm_vars, & + & nAttributes=nm_atts,unlimitedDimId=nm_unlm) +!- + IF (PRESENT(nb_dims)) nb_dims = nm_dims; + IF (PRESENT(nb_vars)) nb_vars = nm_vars; + IF (PRESENT(nb_atts)) nb_atts = nm_atts; + IF (PRESENT(id_unlm)) id_unlm = nm_unlm; +!- + IF (PRESENT(nn_idm)) nn_idm(:) = -1; + IF (PRESENT(nn_ldm)) nn_ldm(:) = 0; + IF (PRESENT(cc_ndm)) cc_ndm(:) = ' '; + IF (PRESENT(nn_aid)) nn_aid(:) = -1; +!- + DO kv=1,nm_dims +!--- + i_rc = NF90_INQUIRE_DIMENSION(f_e,kv,name=f_d_n,len=ml) + CALL strlowercase (f_d_n) + f_d_n = ADJUSTL(f_d_n) +!--- + IF (l_dbg) THEN + WRITE(*,*) " flio_inf ",kv,ml," ",TRIM(f_d_n) + ENDIF +!--- + IF (PRESENT(nn_idm)) nn_idm(kv)=kv; + IF (PRESENT(nn_ldm)) nn_ldm(kv)=ml; + IF (PRESENT(cc_ndm)) cc_ndm(kv)=TRIM(f_d_n); +!--- + IF ( (INDEX(f_d_n,'x') == 1) & + & .OR.(INDEX(f_d_n,'lon') == 1) ) THEN + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_lon) < 0) THEN + nn_aid(k_lon)=kv; + ENDIF + ENDIF + ELSE IF ( (INDEX(f_d_n,'y') == 1) & + & .OR.(INDEX(f_d_n,'lat') == 1) ) THEN + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_lat) < 0) THEN + nn_aid(k_lat)=kv; + ENDIF + ENDIF + ELSE IF ( (INDEX(f_d_n,'z') == 1) & + & .OR.(INDEX(f_d_n,'lev') == 1) & + & .OR.(INDEX(f_d_n,'plev') == 1) & + & .OR.(INDEX(f_d_n,'depth') == 1) ) THEN + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_lev) < 0) THEN + nn_aid(k_lev)=kv; + ENDIF + ENDIF + ELSE IF ( (TRIM(f_d_n) == 't') & + & .OR.(TRIM(f_d_n) == 'time') & + & .OR.(INDEX(f_d_n,'tstep') == 1) & + & .OR.(INDEX(f_d_n,'time_counter') == 1) ) THEN +!---- For the time we certainly need to allow for other names + IF (PRESENT(nn_aid)) THEN + IF (nn_aid(k_tim) < 0) THEN + nn_aid(k_tim)=kv; + ENDIF + ENDIF + ENDIF +!--- + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-flio_inf" + ENDIF +!---------------------- +END SUBROUTINE flio_inf +!=== +SUBROUTINE flio_qax (f_i,axtype,i_v,nbd) +!--------------------------------------------------------------------- +!- This subroutine explores the file in order to find +!- an axis (x/y/z/t) according to a number of rules +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: f_i,i_v,nbd + CHARACTER(LEN=*) :: axtype +!- + INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb + CHARACTER(LEN=1) :: c_ax + CHARACTER(LEN=18) :: c_sn + CHARACTER(LEN=15),DIMENSION(10) :: c_r + CHARACTER(LEN=40) :: c_t1,c_t2 +!--------------------------------------------------------------------- + i_v = -1; nbd = -1; +!--- +!- Keep the name of the axis +!--- + c_ax = TRIM(axtype) +!- +! Validate axis type +!- + IF ( (LEN_TRIM(axtype) == 1) & + & .AND.( (c_ax == 'x').OR.(c_ax == 'y') & + & .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN +!--- +!-- Define the maximum number of dimensions for the coordinate +!--- + SELECT CASE (c_ax) + CASE('x') + l_d = 2 + c_sn = 'longitude' + CASE('y') + l_d = 2 + c_sn = 'latitude' + CASE('z') + l_d = 1 + c_sn = 'model_level_number' + CASE('t') + l_d = 1 + c_sn = 'time' + END SELECT +!--- +!-- Rule 1 : we look for a variable with one dimension +!-- and which has the same name as its dimension (NUG) +!--- + IF (i_v < 0) THEN + SELECT CASE (c_ax) + CASE('x') + k = nw_ai(k_lon,f_i) + CASE('y') + k = nw_ai(k_lat,f_i) + CASE('z') + k = nw_ai(k_lev,f_i) + CASE('t') + k = nw_ai(k_tim,f_i) + END SELECT + IF ( (k >= 1).AND.(k <= nb_ax_mx) ) THEN + dimnb = nw_di(k,f_i) + ELSE + dimnb = -1 + ENDIF +!----- + i_rc = NF90_INQUIRE_DIMENSION(nw_id(f_i),dimnb,name=c_t1) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + L_R1: DO kv=1,nw_nv(f_i) + i_rc = NF90_INQUIRE_VARIABLE & + & (nw_id(f_i),kv,name=c_t2,ndims=n_d) + IF (n_d == 1) THEN + CALL strlowercase (c_t2) + IF (TRIM(c_t1) == TRIM(c_t2)) THEN + i_v = kv; nbd = n_d; + EXIT L_R1 + ENDIF + ENDIF + ENDDO L_R1 + ENDIF + ENDIF +!--- +!-- Rule 2 : we look for a correct "axis" attribute (CF) +!--- + IF (i_v < 0) THEN + L_R2: DO kv=1,nw_nv(f_i) + i_rc = NF90_GET_ATT(nw_id(f_i),kv,'axis',c_t1) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + IF (TRIM(c_t1) == c_ax) THEN + i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d) + IF (n_d <= l_d) THEN + i_v = kv; nbd = n_d; + EXIT L_R2 + ENDIF + ENDIF + ENDIF + ENDDO L_R2 + ENDIF +!--- +!-- Rule 3 : we look for a correct "standard_name" attribute (CF) +!--- + IF (i_v < 0) THEN + L_R3: DO kv=1,nw_nv(f_i) + i_rc = NF90_GET_ATT(nw_id(f_i),kv,'standard_name',c_t1) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + IF (TRIM(c_t1) == TRIM(c_sn)) THEN + i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d) + IF (n_d <= l_d) THEN + i_v = kv; nbd = n_d; + EXIT L_R3 + ENDIF + ENDIF + ENDIF + ENDDO L_R3 + ENDIF +!--- +!-- Rule 4 : we look for a specific name (IOIPSL) +!--- + IF (i_v < 0) THEN + SELECT CASE (c_ax) + CASE('x') + n_r = 3 + c_r(1)='nav_lon'; c_r(2)='lon'; c_r(3)='longitude'; + CASE('y') + n_r = 3 + c_r(1)='nav_lat'; c_r(2)='lat'; c_r(3)='latitude'; + CASE('z') + n_r = 8 + c_r(1)='depth'; c_r(2)='deptht'; c_r(3)='height'; + c_r(4)='level'; c_r(5)='lev'; c_r(6)='plev'; + c_r(7)='sigma_level'; c_r(8)='layer'; + CASE('t') + n_r = 3 + c_r(1)='time'; c_r(2)='tstep'; c_r(3)='timesteps'; + END SELECT +!----- + L_R4: DO kv=1,nw_nv(f_i) + i_rc = NF90_INQUIRE_VARIABLE & + & (nw_id(f_i),kv,name=c_t1,ndims=n_d) + IF (i_rc == NF90_NOERR) THEN + CALL strlowercase (c_t1) + IF (n_d <= l_d) THEN + DO k=1,n_r + IF (TRIM(c_t1) == TRIM(c_r(k))) THEN + i_v = kv; nbd = n_d; + EXIT L_R4 + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO L_R4 + ENDIF +!--- + ENDIF +!---------------------- +END SUBROUTINE flio_qax +!- +!=== +!- +END MODULE fliocom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/getincom.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/getincom.f90 new file mode 100644 index 0000000..f7f8d6f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/getincom.f90 @@ -0,0 +1,2008 @@ +MODULE getincom +!- +!$Id: getincom.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +USE errioipsl, ONLY : ipslerr +USE stringop, & + & ONLY : nocomma,cmpblank,strlowercase +!- +IMPLICIT NONE +!- +PRIVATE +PUBLIC :: getin_name, getin, getin_dump +!- +!!-------------------------------------------------------------------- +!! The "getin_name" routine allows the user to change the name +!! of the definition file in which the data will be read. +!! ("run.def" by default) +!! +!! SUBROUTINE getin_name (file_name) +!! +!! OPTIONAL INPUT argument +!! +!! (C) file_name : the name of the file +!! in which the data will be read +!!-------------------------------------------------------------------- +!- +!- +INTERFACE getin +!!-------------------------------------------------------------------- +!! The "getin" routines get a variable. +!! We first check if we find it in the database +!! and if not we get it from the definition file. +!! +!! SUBROUTINE getin (target,ret_val) +!! +!! INPUT +!! +!! (C) target : Name of the variable +!! +!! OUTPUT +!! +!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain +!! that will contain the (standard) +!! integer/real/character/logical values +!!-------------------------------------------------------------------- + MODULE PROCEDURE getinrs, getinr1d, getinr2d, & + & getinis, getini1d, getini2d, & + & getincs, getinc1d, getinc2d, & + & getinls, getinl1d, getinl2d +END INTERFACE +!- +!!-------------------------------------------------------------------- +!! The "getin_dump" routine will dump the content of the database +!! into a file which has the same format as the definition file. +!! The idea is that the user can see which parameters were used +!! and re-use the file for another run. +!! +!! SUBROUTINE getin_dump (fileprefix) +!! +!! OPTIONAL INPUT argument +!! +!! (C) fileprefix : allows the user to change the name of the file +!! in which the data will be archived +!!-------------------------------------------------------------------- +!- + INTEGER,PARAMETER :: max_files=100 + CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist + INTEGER,SAVE :: nbfiles +!- + INTEGER,SAVE :: allread=0 + CHARACTER(LEN=100),SAVE :: def_file = 'run.def' +!- + INTEGER,PARAMETER :: i_txtslab=1000,l_n=30 + INTEGER,SAVE :: nb_lines,i_txtsize=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier + CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline +!- + INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15 + CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)' +!- +! The data base of parameters +!- + INTEGER,PARAMETER :: memslabs=200 + INTEGER,PARAMETER :: compress_lim=20 +!- + INTEGER,SAVE :: nb_keys=0 + INTEGER,SAVE :: keymemsize=0 +!- +! keystr definition +! name of a key +!- +! keystatus definition +! keystatus = 1 : Value comes from the file defined by 'def_file' +! keystatus = 2 : Default value is used +! keystatus = 3 : Some vector elements were taken from default +!- +! keytype definition +! keytype = 1 : Integer +! keytype = 2 : Real +! keytype = 3 : Character +! keytype = 4 : Logical +!- + INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4 +!- +! Allow compression for keys (only for integer and real) +! keycompress < 0 : not compressed +! keycompress > 0 : number of repeat of the value +!- +TYPE :: t_key + CHARACTER(LEN=l_n) :: keystr + INTEGER :: keystatus, keytype, keycompress, & + & keyfromfile, keymemstart, keymemlen +END TYPE t_key +!- + TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab +!- + INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem + INTEGER,SAVE :: i_memsize=0, i_mempos=0 + REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem + INTEGER,SAVE :: r_memsize=0, r_mempos=0 + CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem + INTEGER,SAVE :: c_memsize=0, c_mempos=0 + LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem + INTEGER,SAVE :: l_memsize=0, l_mempos=0 +!- +CONTAINS +!- +!=== DEFINITION FILE NAME INTERFACE +!- +SUBROUTINE getin_name (cname) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: cname +!--------------------------------------------------------------------- + IF (allread == 0) THEN + def_file = ADJUSTL(cname) + ELSE + CALL ipslerr (3,'getin_name', & + & 'The name of the database file (any_name.def)', & + & 'must be changed *before* any attempt','to read the database.') + ENDIF +!------------------------ +END SUBROUTINE getin_name +!- +!=== INTEGER INTERFACE +!- +SUBROUTINE getinis (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: ret_val +!- + INTEGER,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,i_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinis +!=== +SUBROUTINE getini1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getini1d +!=== +SUBROUTINE getini2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:,:) :: ret_val +!- + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,i_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,i_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getini2d +!- +!=== REAL INTERFACE +!- +SUBROUTINE getinrs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL :: ret_val +!- + REAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,r_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinrs +!=== +SUBROUTINE getinr1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinr1d +!=== +SUBROUTINE getinr2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + REAL,DIMENSION(:,:) :: ret_val +!- + REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,r_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,r_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinr2d +!- +!=== CHARACTER INTERFACE +!- +SUBROUTINE getincs (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,c_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getincs +!=== +SUBROUTINE getinc1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinc1d +!=== +SUBROUTINE getinc2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val +!- + CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,c_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,c_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinc2d +!- +!=== LOGICAL INTERFACE +!- +SUBROUTINE getinls (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL :: ret_val +!- + LOGICAL,DIMENSION(1) :: tmp_ret_val + INTEGER :: pos,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + tmp_ret_val(1) = ret_val +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,1,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,1,target,l_val=tmp_ret_val) + ENDIF + ret_val = tmp_ret_val(1) +!--------------------- +END SUBROUTINE getinls +!=== +SUBROUTINE getinl1d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,status=0,fileorig +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF + tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in) +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF + ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in) +!---------------------- +END SUBROUTINE getinl1d +!=== +SUBROUTINE getinl2d (target,ret_val) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + LOGICAL,DIMENSION(:,:) :: ret_val +!- + LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val + INTEGER,SAVE :: tmp_ret_size = 0 + INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig + INTEGER :: jl,jj,ji +!--------------------------------------------------------------------- +!- +! Do we have this target in our database ? +!- + CALL get_findkey (1,target,pos) +!- + size_of_in = SIZE(ret_val) + size_1 = SIZE(ret_val,1) + size_2 = SIZE(ret_val,2) + IF (.NOT.ALLOCATED(tmp_ret_val)) THEN + ALLOCATE (tmp_ret_val(size_of_in)) + ELSE IF (size_of_in > tmp_ret_size) THEN + DEALLOCATE (tmp_ret_val) + ALLOCATE (tmp_ret_val(size_of_in)) + tmp_ret_size = size_of_in + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + tmp_ret_val(jl) = ret_val(ji,jj) + ENDDO + ENDDO +!- + IF (pos < 0) THEN +!-- Get the information out of the file + CALL get_fil (target,status,fileorig,l_val=tmp_ret_val) +!-- Put the data into the database + CALL get_wdb & + & (target,status,fileorig,size_of_in,l_val=tmp_ret_val) + ELSE +!-- Get the value out of the database + CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val) + ENDIF +!- + jl=0 + DO jj=1,size_2 + DO ji=1,size_1 + jl=jl+1 + ret_val(ji,jj) = tmp_ret_val(jl) + ENDDO + ENDDO +!---------------------- +END SUBROUTINE getinl2d +!- +!=== Generic file/database INTERFACE +!- +SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Subroutine that will extract from the file the values +!- attributed to the keyword target +!- +!- (C) target : target for which we will look in the file +!- (I) status : tells us from where we obtained the data +!- (I) fileorig : index of the file from which the key comes +!- (I) i_val(:) : INTEGER(nb_to_ret) values +!- (R) r_val(:) : REAL(nb_to_ret) values +!- (L) l_val(:) : LOGICAL(nb_to_ret) values +!- (C) c_val(:) : CHARACTER(nb_to_ret) values +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER,INTENT(OUT) :: status,fileorig + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=80) :: str_READ,str_READ_lower + CHARACTER(LEN=9) :: c_vtyp + LOGICAL,DIMENSION(:),ALLOCATABLE :: found + LOGICAL :: def_beha,compressed + CHARACTER(LEN=10) :: c_fmt + INTEGER :: i_cmpval + REAL :: r_cmpval + INTEGER :: ipos_tr,ipos_fl +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + SELECT CASE (k_typ) + CASE(k_i) + nb_to_ret = SIZE(i_val) + CASE(k_r) + nb_to_ret = SIZE(r_val) + CASE(k_c) + nb_to_ret = SIZE(c_val) + CASE(k_l) + nb_to_ret = SIZE(l_val) + CASE DEFAULT + CALL ipslerr (3,'get_fil', & + & 'Internal error','Unknown type of data',' ') + END SELECT +!- +! Read the file(s) + CALL getin_read +!- +! Allocate and initialize the memory we need + ALLOCATE(found(nb_to_ret)) + found(:) = .FALSE. +!- +! See what we find in the files read + DO it=1,nb_to_ret +!--- +!-- First try the target as it is + CALL get_findkey (2,target,pos) +!--- +!-- Another try +!--- + IF (pos < 0) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + CALL get_findkey (2,TRIM(target)//'__'//cnt,pos) + ENDIF +!--- +!-- We dont know from which file the target could come. +!-- Thus by default we attribute it to the first file : + fileorig = 1 +!--- + IF (pos > 0) THEN +!----- + found(it) = .TRUE. + fileorig = fromfile(pos) +!----- +!---- DECODE +!----- + str_READ = ADJUSTL(fichier(pos)) + str_READ_lower = str_READ + CALL strlowercase (str_READ_lower) +!----- + IF ( (TRIM(str_READ_lower) == 'def') & + & .OR.(TRIM(str_READ_lower) == 'default') ) THEN + def_beha = .TRUE. + ELSE + def_beha = .FALSE. + len_str = LEN_TRIM(str_READ) + io_err = 0 + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str + READ (UNIT=str_READ(1:len_str), & + & FMT=c_fmt,IOSTAT=io_err) i_val(it) + CASE(k_r) + READ (UNIT=str_READ(1:len_str), & + & FMT=*,IOSTAT=io_err) r_val(it) + CASE(k_c) + c_val(it) = str_READ(1:len_str) + CASE(k_l) + ipos_tr = -1 + ipos_fl = -1 + ipos_tr = MAX(INDEX(str_READ_lower,'tru'), & + & INDEX(str_READ_lower,'y')) + ipos_fl = MAX(INDEX(str_READ_lower,'fal'), & + & INDEX(str_READ_lower,'n')) + IF (ipos_tr > 0) THEN + l_val(it) = .TRUE. + ELSE IF (ipos_fl > 0) THEN + l_val(it) = .FALSE. + ELSE + io_err = 100 + ENDIF + END SELECT + IF (io_err /= 0) THEN + CALL ipslerr (3,'get_fil', & + & 'Target '//TRIM(target), & + & 'is not of '//TRIM(c_vtyp)//' type',' ') + ENDIF + ENDIF +!----- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!------- +!------ Is this the value of a compressed field ? + compressed = (compline(pos) > 0) + IF (compressed) THEN + IF (compline(pos) /= nb_to_ret) THEN + CALL ipslerr (2,'get_fil', & + & 'For key '//TRIM(target)//' we have a compressed field', & + & 'which does not have the right size.', & + & 'We will try to fix that.') + ENDIF + IF (k_typ == k_i) THEN + i_cmpval = i_val(it) + ELSE IF (k_typ == k_r) THEN + r_cmpval = r_val(it) + ENDIF + ENDIF + ENDIF + ELSE + found(it) = .FALSE. + def_beha = .FALSE. + compressed = .FALSE. + ENDIF + ENDDO +!- + IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN +!--- +!-- If this is a compressed field then we will uncompress it + IF (compressed) THEN + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + IF (k_typ == k_i) THEN + i_val(it) = i_cmpval + ELSE IF (k_typ == k_r) THEN + ENDIF + found(it) = .TRUE. + ENDIF + ENDDO + ENDIF + ENDIF +!- +! Now we set the status for what we found + IF (def_beha) THEN + status = 2 + WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target) + ELSE + status_cnt = 0 + DO it=1,nb_to_ret + IF (.NOT.found(it)) THEN + status_cnt = status_cnt+1 + IF (status_cnt <= max_msgs) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', & + & ADVANCE='NO') TRIM(target) + IF (nb_to_ret > 1) THEN + WRITE (UNIT=*,FMT='("__")',ADVANCE='NO') + WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it + ENDIF + SELECT CASE (k_typ) + CASE(k_i) + WRITE (UNIT=*,FMT=*) "=",i_val(it) + CASE(k_r) + WRITE (UNIT=*,FMT=*) "=",r_val(it) + CASE(k_c) + WRITE (UNIT=*,FMT=*) "=",c_val(it) + CASE(k_l) + WRITE (UNIT=*,FMT=*) "=",l_val(it) + END SELECT + ELSE IF (status_cnt == max_msgs+1) THEN + WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)') + ENDIF + ENDIF + ENDDO +!--- + IF (status_cnt == 0) THEN + status = 1 + ELSE IF (status_cnt == nb_to_ret) THEN + status = 2 + ELSE + status = 3 + ENDIF + ENDIF +! Deallocate the memory + DEALLOCATE(found) +!--------------------- +END SUBROUTINE get_fil +!=== +SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Read the required variable in the database +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: pos,size_of_in + CHARACTER(LEN=*) :: target + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ,k_beg,k_end + CHARACTER(LEN=9) :: c_vtyp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_rdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- + IF (key_tab(pos)%keytype /= k_typ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong data type for keyword '//TRIM(target), & + & '(NOT '//TRIM(c_vtyp)//')',' ') + ENDIF +!- + IF (key_tab(pos)%keycompress > 0) THEN + IF ( (key_tab(pos)%keycompress /= size_of_in) & + & .OR.(key_tab(pos)%keymemlen /= 1) ) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong compression length','for keyword '//TRIM(target),' ') + ELSE + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart) + CASE(k_r) + r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart) + END SELECT + ENDIF + ELSE + IF (key_tab(pos)%keymemlen /= size_of_in) THEN + CALL ipslerr (3,'get_rdb', & + & 'Wrong array length','for keyword '//TRIM(target),' ') + ELSE + k_beg = key_tab(pos)%keymemstart + k_end = k_beg+key_tab(pos)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_val(1:size_of_in) = i_mem(k_beg:k_end) + CASE(k_r) + r_val(1:size_of_in) = r_mem(k_beg:k_end) + CASE(k_c) + c_val(1:size_of_in) = c_mem(k_beg:k_end) + CASE(k_l) + l_val(1:size_of_in) = l_mem(k_beg:k_end) + END SELECT + ENDIF + ENDIF +!--------------------- +END SUBROUTINE get_rdb +!=== +SUBROUTINE get_wdb & + & (target,status,fileorig,size_of_in, & + & i_val,r_val,c_val,l_val) +!--------------------------------------------------------------------- +!- Write data into the data base +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: target + INTEGER :: status,fileorig,size_of_in + INTEGER,DIMENSION(:),OPTIONAL :: i_val + REAL,DIMENSION(:),OPTIONAL :: r_val + LOGICAL,DIMENSION(:),OPTIONAL :: l_val + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val +!- + INTEGER :: k_typ + CHARACTER(LEN=9) :: c_vtyp + INTEGER :: k_mempos,k_memsize,k_beg,k_end + LOGICAL :: l_cmp +!--------------------------------------------------------------------- +!- +! Get the type of the argument + CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val) + IF ( (k_typ /= k_i).AND.(k_typ /= k_r) & + & .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN + CALL ipslerr (3,'get_wdb', & + & 'Internal error','Unknown type of data',' ') + ENDIF +!- +! First check if we have sufficiant space for the new key + IF (nb_keys+1 > keymemsize) THEN + CALL getin_allockeys () + ENDIF +!- + SELECT CASE (k_typ) + CASE(k_i) + k_mempos = i_mempos; k_memsize = i_memsize; + l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_r) + k_mempos = r_mempos; k_memsize = r_memsize; + l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) & + & .AND.(size_of_in > compress_lim) + CASE(k_c) + k_mempos = c_mempos; k_memsize = c_memsize; + l_cmp = .FALSE. + CASE(k_l) + k_mempos = l_mempos; k_memsize = l_memsize; + l_cmp = .FALSE. + END SELECT +!- +! Fill out the items of the data base + nb_keys = nb_keys+1 + key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n)) + key_tab(nb_keys)%keystatus = status + key_tab(nb_keys)%keytype = k_typ + key_tab(nb_keys)%keyfromfile = fileorig + key_tab(nb_keys)%keymemstart = k_mempos+1 + IF (l_cmp) THEN + key_tab(nb_keys)%keycompress = size_of_in + key_tab(nb_keys)%keymemlen = 1 + ELSE + key_tab(nb_keys)%keycompress = -1 + key_tab(nb_keys)%keymemlen = size_of_in + ENDIF +!- +! Before writing the actual size lets see if we have the space + IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen & + & > k_memsize) THEN + CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen) + ENDIF +!- + k_beg = key_tab(nb_keys)%keymemstart + k_end = k_beg+key_tab(nb_keys)%keymemlen-1 + SELECT CASE (k_typ) + CASE(k_i) + i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen) + i_mempos = k_end + CASE(k_r) + r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen) + r_mempos = k_end + CASE(k_c) + c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen) + c_mempos = k_end + CASE(k_l) + l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen) + l_mempos = k_end + END SELECT +!--------------------- +END SUBROUTINE get_wdb +!- +!=== +!- +SUBROUTINE getin_read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,SAVE :: current +!--------------------------------------------------------------------- + IF (allread == 0) THEN +!-- Allocate a first set of memory. + CALL getin_alloctxt () + CALL getin_allockeys () + CALL getin_allocmem (k_i,0) + CALL getin_allocmem (k_r,0) + CALL getin_allocmem (k_c,0) + CALL getin_allocmem (k_l,0) +!-- Start with reading the files + nbfiles = 1 + filelist(1) = TRIM(def_file) + current = 1 +!-- + DO WHILE (current <= nbfiles) + CALL getin_readdef (current) + current = current+1 + ENDDO + allread = 1 + CALL getin_checkcohe () + ENDIF +!------------------------ +END SUBROUTINE getin_read +!- +!=== +!- + SUBROUTINE getin_readdef(current) +!--------------------------------------------------------------------- +!- This subroutine will read the files and only keep the +!- the relevant information. The information is kept as it +!- found in the file. The data will be analysed later. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: current +!- + CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt + INTEGER :: nb_lastkey +!- + INTEGER :: eof,ptn,len_str,i,it,iund,io_err + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + eof = 0 + ptn = 1 + nb_lastkey = 0 +!- + IF (check) THEN + WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current)) + ENDIF +!- + OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err) + IF (io_err /= 0) THEN + CALL ipslerr (2,'getin_readdef', & + & 'Could not open file '//TRIM(filelist(current)),' ',' ') + RETURN + ENDIF +!- + DO WHILE (eof /= 1) +!--- + CALL getin_skipafew (22,READ_str,eof,nb_lastkey) + len_str = LEN_TRIM(READ_str) + ptn = INDEX(READ_str,'=') +!--- + IF (ptn > 0) THEN +!---- Get the target + key_str = TRIM(ADJUSTL(READ_str(1:ptn-1))) +!---- Make sure that a vector keyword has the right length + iund = INDEX(key_str,'__') + IF (iund > 0) THEN + WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') & + & LEN_TRIM(key_str)-iund-1 + READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), & + & FMT=c_fmt,IOSTAT=io_err) it + IF ( (io_err == 0).AND.(it > 0) ) THEN + WRITE(UNIT=cnt,FMT=c_i_fmt) it + key_str = key_str(1:iund+1)//cnt + ELSE + CALL ipslerr (3,'getin_readdef', & + & 'A very strange key has just been found :', & + & TRIM(key_str),' ') + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str))) + CALL nocomma (NEW_str) + CALL cmpblank (NEW_str) + NEW_str = TRIM(ADJUSTL(NEW_str)) + IF (check) THEN + WRITE(*,*) & + & '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str) + ENDIF +!---- Decypher the content of NEW_str +!- +!---- This has to be a new key word, thus : + nb_lastkey = 0 +!---- + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) +!---- + ELSE IF (len_str > 0) THEN +!---- Prepare the key if we have an old one to which +!---- we will add the line just read + IF (nb_lastkey > 0) THEN + iund = INDEX(last_key,'__') + IF (iund > 0) THEN +!-------- We only continue a keyword, thus it is easy + key_str = last_key(1:iund-1) + ELSE + IF (nb_lastkey /= 1) THEN + CALL ipslerr (3,'getin_readdef', & + & 'We can not have a scalar keyword', & + & 'and a vector content',' ') + ENDIF +!-------- The last keyword needs to be transformed into a vector. + WRITE(UNIT=cnt,FMT=c_i_fmt) 1 + targetlist(nb_lines) = & + & last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt + key_str = last_key(1:LEN_TRIM(last_key)) + ENDIF + ENDIF +!---- Prepare the content + NEW_str = TRIM(ADJUSTL(READ_str(1:len_str))) + CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey) + ELSE +!---- If we have an empty line then the keyword finishes + nb_lastkey = 0 + IF (check) THEN + WRITE(*,*) 'getin_readdef : Have found an emtpy line ' + ENDIF + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + IF (check) THEN + OPEN (UNIT=22,file=TRIM(def_file)//'.test') + DO i=1,nb_lines + WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i) + ENDDO + CLOSE(UNIT=22) + ENDIF +!--------------------------- +END SUBROUTINE getin_readdef +!- +!=== +!- +SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey) +!--------------------------------------------------------------------- +!- This subroutine is going to decypher the line. +!- It essentialy checks how many items are included and +!- it they can be attached to a key. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! ARGUMENTS +!- + INTEGER :: current,nb_lastkey + CHARACTER(LEN=*) :: key_str,NEW_str,last_key +!- +! LOCAL +!- + INTEGER :: len_str,blk,nbve,starpos + CHARACTER(LEN=100) :: tmp_str,new_key,mult + CHARACTER(LEN=n_d_fmt) :: cnt + CHARACTER(LEN=10) :: c_fmt +!--------------------------------------------------------------------- + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + tmp_str = NEW_str(1:len_str) +!- +! If the key is a new file then we take it up. Else +! we save the line and go on. +!- + IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN + DO WHILE (blk > 0) + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!----- + nbfiles = nbfiles+1 + filelist(nbfiles) = tmp_str(1:blk) +!----- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ') + ENDDO +!--- + IF (nbfiles+1 > max_files) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'Too many files to include',' ',' ') + ENDIF +!--- + nbfiles = nbfiles+1 + filelist(nbfiles) = TRIM(ADJUSTL(tmp_str)) +!--- + last_key = 'INCLUDEDEF' + nb_lastkey = 1 + ELSE +!- +!-- We are working on a new line of input +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 +!- +!-- First we solve the issue of conpressed information. Once +!-- this is done all line can be handled in the same way. +!- + starpos = INDEX(NEW_str(1:len_str),'*') + IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') & + & .AND.(tmp_str(1:1) /= "'") ) THEN +!----- + IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We can not have a compressed field of values', & + & 'in a vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str)) + ENDIF +!- +!---- Read the multiplied +!- + mult = TRIM(ADJUSTL(NEW_str(1:starpos-1))) +!---- Construct the new string and its parameters + NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str))) + len_str = LEN_TRIM(NEW_str) + blk = INDEX(NEW_str(1:len_str),' ') + IF (blk > 1) THEN + CALL ipslerr (2,'getin_decrypt', & + & 'This is a strange behavior','you could report',' ') + ENDIF + WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult) + READ(UNIT=mult,FMT=c_fmt) compline(nb_lines) +!--- + ELSE + compline(nb_lines) = -1 + ENDIF +!- +!-- If there is no space wthin the line then the target is a scalar +!-- or the element of a properly written vector. +!-- (ie of the type TARGET__00001) +!- + IF ( (blk <= 1) & + & .OR.(tmp_str(1:1) == '"') & + & .OR.(tmp_str(1:1) == "'") ) THEN +!- + IF (nb_lastkey == 0) THEN +!------ Save info of current keyword as a scalar +!------ if it is not a continuation + targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n)) + nb_lastkey = 1 + ELSE +!------ We are continuing a vector so the keyword needs +!------ to get the underscores + WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1 + targetlist(nb_lines) = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nb_lastkey+1 + ENDIF +!----- + fichier(nb_lines) = NEW_str(1:len_str) + fromfile(nb_lines) = current + ELSE +!- +!---- If there are blanks whithin the line then we are dealing +!---- with a vector and we need to split it in many entries +!---- with the TARGET__n notation. +!---- +!---- Test if the targer is not already a vector target ! +!- + IF (INDEX(TRIM(key_str),'__') > 0) THEN + CALL ipslerr (3,'getin_decrypt', & + & 'We have found a mixed vector notation (TARGET__n).', & + & 'The key at fault : '//TRIM(key_str),' ') + ENDIF +!- + nbve = nb_lastkey + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + DO WHILE (blk > 0) +!- +!------ Save the content of target__nbve +!- + fichier(nb_lines) = tmp_str(1:blk) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str)))) + blk = INDEX(TRIM(tmp_str),' ') +!- + IF (nb_lines+1 > i_txtsize) THEN + CALL getin_alloctxt () + ENDIF + nb_lines = nb_lines+1 + nbve = nbve+1 + WRITE(UNIT=cnt,FMT=c_i_fmt) nbve +!- + ENDDO +!- +!---- Save the content of the last target +!- + fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str)) + new_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n)) + fromfile(nb_lines) = current +!- + last_key = & + & key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt + nb_lastkey = nbve +!- + ENDIF +!- + ENDIF +!--------------------------- +END SUBROUTINE getin_decrypt +!- +!=== +!- +SUBROUTINE getin_checkcohe () +!--------------------------------------------------------------------- +!- This subroutine checks for redundancies. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: line,n_k,k +!--------------------------------------------------------------------- + DO line=1,nb_lines-1 +!- + n_k = 0 + DO k=line+1,nb_lines + IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN + n_k = k + EXIT + ENDIF + ENDDO +!--- +!-- IF we have found it we have a problem to solve. +!--- + IF (n_k > 0) THEN + WRITE(*,*) 'COUNT : ',n_k + WRITE(*,*) & + & 'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line)) + WRITE(*,*) & + & 'getin_checkcohe : The following values were encoutered :' + WRITE(*,*) & + & ' ',TRIM(targetlist(line)),' == ',fichier(line) + WRITE(*,*) & + & ' ',TRIM(targetlist(k)),' == ',fichier(k) + WRITE(*,*) & + & 'getin_checkcohe : We will keep only the last value' + targetlist(line) = ' ' + ENDIF + ENDDO +!----------------------------- +END SUBROUTINE getin_checkcohe +!- +!=== +!- +SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: unit,eof,nb_lastkey + CHARACTER(LEN=100) :: dummy + CHARACTER(LEN=100) :: out_string + CHARACTER(LEN=1) :: first +!--------------------------------------------------------------------- + first="#" + eof = 0 + out_string = " " +!- + DO WHILE (first == "#") + READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy + dummy = TRIM(ADJUSTL(dummy)) + first=dummy(1:1) + IF (first == "#") THEN + nb_lastkey = 0 + ENDIF + ENDDO + out_string=dummy +!- + RETURN +!- +9998 CONTINUE + CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ') +!- +7778 CONTINUE + eof = 1 +!---------------------------- +END SUBROUTINE getin_skipafew +!- +!=== +!- +SUBROUTINE getin_allockeys () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + IF (keymemsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp,FMT=*) memslabs + ALLOCATE(key_tab(memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + nb_keys = 0 + keymemsize = memslabs + key_tab(:)%keycompress = -1 +!--- + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp,FMT=*) keymemsize + ALLOCATE(tmp_key_tab(keymemsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate tmp_key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs + tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize) + DEALLOCATE(key_tab) + ALLOCATE(key_tab(keymemsize+memslabs),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_allockeys', & + & 'Can not allocate key_tab', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + key_tab(:)%keycompress = -1 + key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize) + DEALLOCATE(tmp_key_tab) + keymemsize = keymemsize+memslabs + ENDIF +!----------------------------- +END SUBROUTINE getin_allockeys +!- +!=== +!- +SUBROUTINE getin_allocmem (type,len_wanted) +!--------------------------------------------------------------------- +!- Allocate the memory of the data base for all 4 types of memory +!- INTEGER / REAL / CHARACTER / LOGICAL +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: type,len_wanted +!- + INTEGER,ALLOCATABLE :: tmp_int(:) + REAL,ALLOCATABLE :: tmp_real(:) + CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:) + LOGICAL,ALLOCATABLE :: tmp_logic(:) + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp +!--------------------------------------------------------------------- + SELECT CASE (type) + CASE(k_i) + IF (i_memsize == 0) THEN + ALLOCATE(i_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_memsize=memslabs + ELSE + ALLOCATE(tmp_int(i_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_int(1:i_memsize) = i_mem(1:i_memsize) + DEALLOCATE(i_mem) + ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + i_mem(1:i_memsize) = tmp_int(1:i_memsize) + i_memsize = i_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_int) + ENDIF + CASE(k_r) + IF (r_memsize == 0) THEN + ALLOCATE(r_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_memsize = memslabs + ELSE + ALLOCATE(tmp_real(r_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_real', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_real(1:r_memsize) = r_mem(1:r_memsize) + DEALLOCATE(r_mem) + ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + r_mem(1:r_memsize) = tmp_real(1:r_memsize) + r_memsize = r_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_real) + ENDIF + CASE(k_c) + IF (c_memsize == 0) THEN + ALLOCATE(c_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_memsize = memslabs + ELSE + ALLOCATE(tmp_char(c_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_char', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_char(1:c_memsize) = c_mem(1:c_memsize) + DEALLOCATE(c_mem) + ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + c_mem(1:c_memsize) = tmp_char(1:c_memsize) + c_memsize = c_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_char) + ENDIF + CASE(k_l) + IF (l_memsize == 0) THEN + ALLOCATE(l_mem(memslabs),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) memslabs + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_memsize = memslabs + ELSE + ALLOCATE(tmp_logic(l_memsize),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to allocate tmp_logic', & + & 'to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + tmp_logic(1:l_memsize) = l_mem(1:l_memsize) + DEALLOCATE(l_mem) + ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier) + IF (ier /= 0) THEN + WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted) + CALL ipslerr (3,'getin_allocmem', & + & 'Unable to re-allocate db-memory', & + & 'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ') + ENDIF + l_mem(1:l_memsize) = tmp_logic(1:l_memsize) + l_memsize = l_memsize+MAX(memslabs,len_wanted) + DEALLOCATE(tmp_logic) + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ') + END SELECT +!---------------------------- +END SUBROUTINE getin_allocmem +!- +!=== +!- +SUBROUTINE getin_alloctxt () +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:) + CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:) + INTEGER,ALLOCATABLE :: tmp_int(:) +!- + INTEGER :: ier + CHARACTER(LEN=20) :: c_tmp1,c_tmp2 +!--------------------------------------------------------------------- + IF (i_txtsize == 0) THEN +!--- +!-- Nothing exists in memory arrays and it is easy to do. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtslab + ALLOCATE(fichier(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(targetlist(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(fromfile(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + ALLOCATE(compline(i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF +!--- + nb_lines = 0 + i_txtsize = i_txtslab + ELSE +!--- +!-- There is something already in the memory, +!-- we need to transfer and reallocate. +!--- + WRITE (UNIT=c_tmp1,FMT=*) i_txtsize + WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab + ALLOCATE(tmp_fic(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_fic', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_fic(1:i_txtsize) = fichier(1:i_txtsize) + DEALLOCATE(fichier) + ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fichier', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fichier(1:i_txtsize) = tmp_fic(1:i_txtsize) + DEALLOCATE(tmp_fic) +!--- + ALLOCATE(tmp_tgl(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_tgl', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize) + DEALLOCATE(targetlist) + ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate targetlist', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize) + DEALLOCATE(tmp_tgl) +!--- + ALLOCATE(tmp_int(i_txtsize),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate tmp_int', & + & 'to size '//TRIM(ADJUSTL(c_tmp1)),' ') + ENDIF + tmp_int(1:i_txtsize) = fromfile(1:i_txtsize) + DEALLOCATE(fromfile) + ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate fromfile', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + fromfile(1:i_txtsize) = tmp_int(1:i_txtsize) +!--- + tmp_int(1:i_txtsize) = compline(1:i_txtsize) + DEALLOCATE(compline) + ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier) + IF (ier /= 0) THEN + CALL ipslerr (3,'getin_alloctxt', & + & 'Can not allocate compline', & + & 'to size '//TRIM(ADJUSTL(c_tmp2)),' ') + ENDIF + compline(1:i_txtsize) = tmp_int(1:i_txtsize) + DEALLOCATE(tmp_int) +!--- + i_txtsize = i_txtsize+i_txtslab + ENDIF +!---------------------------- +END SUBROUTINE getin_alloctxt +!- +!=== +!- +SUBROUTINE getin_dump (fileprefix) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(*),OPTIONAL :: fileprefix +!- + CHARACTER(LEN=80) :: usedfileprefix + INTEGER :: ikey,if,iff,iv + CHARACTER(LEN=20) :: c_tmp + CHARACTER(LEN=100) :: tmp_str,used_filename + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (PRESENT(fileprefix)) THEN + usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80)) + ELSE + usedfileprefix = "used" + ENDIF +!- + DO if=1,nbfiles +!--- + used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if)) + IF (check) THEN + WRITE(*,*) & + & 'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if + WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys + ENDIF + OPEN (UNIT=22,FILE=used_filename) +!--- +!-- If this is the first file we need to add the list +!-- of file which belong to it + IF ( (if == 1).AND.(nbfiles > 1) ) THEN + WRITE(22,*) '# ' + WRITE(22,*) '# This file is linked to the following files :' + WRITE(22,*) '# ' + DO iff=2,nbfiles + WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff)) + ENDDO + WRITE(22,*) '# ' + ENDIF +!--- + DO ikey=1,nb_keys +!----- +!---- Is this key from this file ? + IF (key_tab(ikey)%keyfromfile == if) THEN +!------- +!------ Write some comments + WRITE(22,*) '#' + SELECT CASE (key_tab(ikey)%keystatus) + CASE(1) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file) + CASE(2) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr),' are all defaults.' + CASE(3) + WRITE(22,*) '# Values of ', & + & TRIM(key_tab(ikey)%keystr), & + & ' are a mix of ',TRIM(def_file),' and defaults.' + CASE DEFAULT + WRITE(22,*) '# Dont know from where the value of ', & + & TRIM(key_tab(ikey)%keystr),' comes.' + END SELECT + WRITE(22,*) '#' +!------- +!------ Write the values + SELECT CASE (key_tab(ikey)%keytype) + CASE(k_i) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',i_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',i_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',i_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_r) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (key_tab(ikey)%keycompress < 0) THEN + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',r_mem(key_tab(ikey)%keymemstart) + ELSE + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & ' = ',key_tab(ikey)%keycompress, & + & ' * ',r_mem(key_tab(ikey)%keymemstart) + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',r_mem(key_tab(ikey)%keymemstart+iv) + ENDDO + ENDIF + CASE(k_c) + IF (key_tab(ikey)%keymemlen == 1) THEN + tmp_str = c_mem(key_tab(ikey)%keymemstart) + WRITE(22,*) TRIM(key_tab(ikey)%keystr), & + & ' = ',TRIM(tmp_str) + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + tmp_str = c_mem(key_tab(ikey)%keymemstart+iv) + WRITE(22,*) & + & TRIM(key_tab(ikey)%keystr), & + & '__',TRIM(ADJUSTL(c_tmp)), & + & ' = ',TRIM(tmp_str) + ENDDO + ENDIF + CASE(k_l) + IF (key_tab(ikey)%keymemlen == 1) THEN + IF (l_mem(key_tab(ikey)%keymemstart)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE ' + ENDIF + ELSE + DO iv=0,key_tab(ikey)%keymemlen-1 + WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1 + IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = TRUE ' + ELSE + WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', & + & TRIM(ADJUSTL(c_tmp)),' = FALSE ' + ENDIF + ENDDO + ENDIF + CASE DEFAULT + CALL ipslerr (3,'getin_dump', & + & 'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), & + & ' ',' ') + END SELECT + ENDIF + ENDDO +!- + CLOSE(UNIT=22) +!- + ENDDO +!------------------------ +END SUBROUTINE getin_dump +!=== +SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v) +!--------------------------------------------------------------------- +!- Returns the type of the argument (mutually exclusive) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(OUT) :: k_typ + CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp + INTEGER,DIMENSION(:),OPTIONAL :: i_v + REAL,DIMENSION(:),OPTIONAL :: r_v + LOGICAL,DIMENSION(:),OPTIONAL :: l_v + CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v +!--------------------------------------------------------------------- + k_typ = 0 + IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) & + & /= 1) THEN + CALL ipslerr (3,'get_qtyp', & + & 'Invalid number of optional arguments','(/= 1)',' ') + ENDIF +!- + IF (PRESENT(i_v)) THEN + k_typ = k_i + c_vtyp = 'INTEGER' + ELSEIF (PRESENT(r_v)) THEN + k_typ = k_r + c_vtyp = 'REAL' + ELSEIF (PRESENT(c_v)) THEN + k_typ = k_c + c_vtyp = 'CHARACTER' + ELSEIF (PRESENT(l_v)) THEN + k_typ = k_l + c_vtyp = 'LOGICAL' + ENDIF +!---------------------- +END SUBROUTINE get_qtyp +!=== +SUBROUTINE get_findkey (i_tab,c_key,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a key in a table +!--------------------------------------------------------------------- +!- INPUT +!- i_tab : 1 -> search in key_tab(1:nb_keys)%keystr +!- 2 -> search in targetlist(1:nb_lines) +!- c_key : Name of the key we are looking for +!- OUTPUT +!- pos : -1 if key not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: i_tab + CHARACTER(LEN=*),INTENT(in) :: c_key + INTEGER,INTENT(out) :: pos +!- + INTEGER :: ikey_max,ikey + CHARACTER(LEN=l_n) :: c_q_key +!--------------------------------------------------------------------- + pos = -1 + IF (i_tab == 1) THEN + ikey_max = nb_keys + ELSEIF (i_tab == 2) THEN + ikey_max = nb_lines + ELSE + ikey_max = 0 + ENDIF + IF ( ikey_max > 0 ) THEN + DO ikey=1,ikey_max + IF (i_tab == 1) THEN + c_q_key = key_tab(ikey)%keystr + ELSE + c_q_key = targetlist(ikey) + ENDIF + IF (TRIM(c_q_key) == TRIM(c_key)) THEN + pos = ikey + EXIT + ENDIF + ENDDO + ENDIF +!------------------------- +END SUBROUTINE get_findkey +!=== +!------------------ +END MODULE getincom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/histcom.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/histcom.f90 new file mode 100644 index 0000000..4d5a174 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/histcom.f90 @@ -0,0 +1,2501 @@ +MODULE histcom +!- +!$Id: histcom.f90 2368 2010-11-09 15:38:45Z acc $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!- + USE netcdf + USE nc4interface ! needed to allow compilation with netcdf3 libraries +!- + USE stringop, ONLY : nocomma,cmpblank,findpos,find_str,strlowercase + USE mathelp, ONLY : mathop,moycum,buildop + USE fliocom, ONLY : flio_dom_file,flio_dom_att + USE calendar + USE errioipsl, ONLY : ipslerr,ipsldbg +!- + IMPLICIT NONE +!- + PRIVATE + PUBLIC :: histbeg,histdef,histhori,histvert,histend, & + & histwrite,histclo,histsync,ioconf_modname +!--------------------------------------------------------------------- +!- Some confusing vocabulary in this code ! +!- ========================================= +!- +!- A REGULAR grid is a grid which is i,j indexes +!- and thus it is stored in a 2D matrix. +!- This is opposed to a IRREGULAR grid which is only in a vector +!- and where we do not know which neighbors we have. +!- As a consequence we need the bounds for each grid-cell. +!- +!- A RECTILINEAR grid is a special case of a regular grid +!- in which all longitudes for i constant are equal +!- and all latitudes for j constant. +!- In other words we do not need the full 2D matrix +!- to describe the grid, just two vectors. +!--------------------------------------------------------------------- +!- + INTERFACE histbeg + MODULE PROCEDURE histb_reg1d,histb_reg2d,histb_irreg + END INTERFACE +!- + INTERFACE histhori + MODULE PROCEDURE histh_reg1d,histh_reg2d,histh_irreg + END INTERFACE +!- + INTERFACE histwrite +!--------------------------------------------------------------------- +!- The "histwrite" routines will give the data to the I/O system. +!- It will trigger the operations to be performed, +!- and the writting to the file if needed +!- +!- We test for the work to be done at this time here so that at a +!- later stage we can call different operation and write subroutine +!- for the REAL and INTEGER interfaces +!- +!- INPUT +!- idf : The ID of the file on which this variable is to be, +!- written. The variable should have been defined in +!- this file before. +!- pvarname : The short name of the variable +!- pitau : Current timestep +!- pdata : The variable, I mean the real data ! +!- nbindex : The number of indexes provided. If it is equal to +!- the size of the full field as provided in histdef +!- then nothing is done. +!- nindex : The indices used to expand the variable (pdata) +!- onto the full field. +!--------------------------------------------------------------------- +!- histwrite - we have to prepare different type of fields : +!- real and integer, 1,2 or 3D + MODULE PROCEDURE histwrite_r1d,histwrite_r2d,histwrite_r3d + END INTERFACE +!- +! Fixed parameter +!- + INTEGER,PARAMETER :: nb_files_max=20,nb_var_max=400, & + & nb_hax_max=5,nb_zax_max=10,nbopp_max=10 + REAL,PARAMETER :: missing_val=nf90_fill_real + INTEGER,PARAMETER,PUBLIC :: & + & hist_r4=nf90_real4, hist_r8=nf90_real8 +!- +! Variable derived type +!- +TYPE T_D_V + INTEGER :: ncvid + INTEGER :: nbopp + CHARACTER(LEN=20) :: v_name,unit_name + CHARACTER(LEN=256) :: title,std_name + CHARACTER(LEN=80) :: fullop + CHARACTER(LEN=7) :: topp + CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp + REAL,DIMENSION(nbopp_max) :: scal +!-External type (for R4/R8) + INTEGER :: v_typ +!-Sizes of the associated grid and zommed area + INTEGER,DIMENSION(3) :: scsize,zorig,zsize +!-Sizes for the data as it goes through the various math operations + INTEGER,DIMENSION(3) :: datasz_in = -1 + INTEGER :: datasz_max = -1 +!- + INTEGER :: h_axid,z_axid,t_axid +!- + REAL,DIMENSION(2) :: hist_minmax + LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE. +!-Book keeping of the axes + INTEGER :: tdimid,tbndid=-1,tax_last + LOGICAL :: l_bnd + CHARACTER(LEN=40) :: tax_name +!- + REAL :: freq_opp,freq_wrt + INTEGER :: & + & last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt +!- For future optimization + REAL,POINTER,DIMENSION(:) :: t_bf +!# REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D +!# REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D +!# REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D +END TYPE T_D_V +!- +! File derived type +!- +TYPE :: T_D_F +!-NETCDF IDs for file + INTEGER :: ncfid=-1 +!-Time variables + INTEGER :: itau0=0 + REAL :: date0,deltat +!-Counter of elements (variables, time-horizontal-vertical axis + INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0 +!-NETCDF dimension IDs for time-[time_bounds]-longitude-latitude + INTEGER :: tid,bid,xid,yid +!-General definitions in the NETCDF file + INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_siz +!-The horizontal axes + CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name +!-The vertical axes + INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids + CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name +!- + LOGICAL :: regular=.TRUE. +!-DOMAIN ID + INTEGER :: dom_id_svg=-1 +!- + TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V +END TYPE T_D_F +!- +TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F +!- +! A list of functions which require special action +! (Needs to be updated when functions are added +! but they are well located here) +!- + CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill' +!- Some configurable variables with locks + CHARACTER(LEN=80),SAVE :: model_name='An IPSL model' + LOGICAL,SAVE :: lock_modname=.FALSE. +!- +!=== +CONTAINS +!=== +!- +SUBROUTINE histb_reg1d & + & (pfilename,pim,plon,pjm,plat, & + & par_orix,par_szx,par_oriy,par_szy, & + & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- histbeg for 1D regular horizontal coordinates (see histb_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: pfilename + INTEGER,INTENT(IN) :: pim,pjm + REAL,DIMENSION(pim),INTENT(IN) :: plon + REAL,DIMENSION(pjm),INTENT(IN) :: plat + INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!--------------------------------------------------------------------- + CALL histb_all & + & (1,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_1d=plon,y_1d=plat, & + & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & + & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) +!------------------------- +END SUBROUTINE histb_reg1d +!=== +SUBROUTINE histb_reg2d & + & (pfilename,pim,plon,pjm,plat, & + & par_orix,par_szx,par_oriy,par_szy, & + & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- histbeg for 2D regular horizontal coordinates (see histb_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: pfilename + INTEGER,INTENT(IN) :: pim,pjm + REAL,DIMENSION(pim,pjm),INTENT(IN) :: plon,plat + INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!--------------------------------------------------------------------- + CALL histb_all & + & (2,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_2d=plon,y_2d=plat, & + & k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, & + & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) +!------------------------- +END SUBROUTINE histb_reg2d +!=== +SUBROUTINE histb_irreg & + & (pfilename,pim,plon,plon_bounds,plat,plat_bounds, & + & pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- histbeg for irregular horizontal coordinates (see histb_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: pfilename + INTEGER,INTENT(IN) :: pim + REAL,DIMENSION(pim),INTENT(IN) :: plon,plat + REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!--------------------------------------------------------------------- + CALL histb_all & + & (3,pfilename,pim,pim,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds, & + & domain_id=domain_id,mode=mode,snc4chunks=snc4chunks) +!------------------------- +END SUBROUTINE histb_irreg +!=== +SUBROUTINE histb_all & + & (k_typ,nc_name,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, & + & x_1d,y_1d,x_2d,y_2d,k_orx,k_szx,k_ory,k_szy, & + & x_bnds,y_bnds,domain_id,mode,snc4chunks) +!--------------------------------------------------------------------- +!- General interface for horizontal grids. +!- This subroutine initializes a netcdf file and returns the ID. +!- It will set up the geographical space on which the data will be +!- stored and offers the possibility of seting a zoom. +!- In the case of irregular grids, all the data comes in as vectors +!- and for the grid we have the coordinates of the 4 corners. +!- It also gets the global parameters into the I/O subsystem. +!- +!- INPUT +!- +!- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) +!- nc_name : Name of the netcdf file to be created +!- pim : Size of arrays in longitude direction +!- pjm : Size of arrays in latitude direction (pjm=pim for type 3) +!- +!- pitau0 : time step at which the history tape starts +!- pdate0 : The Julian date at which the itau was equal to 0 +!- pdeltat : Time step, in seconds, of the counter itau +!- used in histwrite for instance +!- +!- OUTPUT +!- +!- phoriid : Identifier of the horizontal grid +!- idf : Identifier of the file +!- +!- Optional INPUT arguments +!- +!- For rectilinear or irregular grid +!- x_1d : The longitudes +!- y_1d : The latitudes +!- For regular grid +!- x_2d : The longitudes +!- y_2d : The latitudes +!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. +!- +!- For regular grid (reg1d or reg2d), +!- the next 4 arguments allow to define a horizontal zoom +!- for this file. It is assumed that all variables to come +!- have the same index space. This can not be assumed for +!- the z axis and thus we define the zoom in histdef. +!- k_orx : Origin of the slab of data within the X axis (pim) +!- k_szx : Size of the slab of data in X +!- k_ory : Origin of the slab of data within the Y axis (pjm) +!- k_szy : Size of the slab of data in Y +!- +!- For irregular grid. +!- x_bnds : The boundaries of the grid in longitude +!- y_bnds : The boundaries of the grid in latitude +!- +!- For all grids. +!- +!- domain_id : Domain identifier +!- +!- mode : String of (case insensitive) blank-separated words +!- defining the mode used to create the file. +!- Supported keywords : 32, 64 +!- "32/64" defines the offset mode. +!- The default offset mode is 64 bits. +!- Keywords "NETCDF4" and "CLASSIC" are reserved +!- for future use. +!- +!- snc4chunks : Structure containing chunk partitioning parameters +!- for 4-D variables and a logical switch to toggle +!- between netcdf3 o/p (false) and netcdf4 chunked +!- and compressed o/p (true) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: k_typ + CHARACTER(LEN=*),INTENT(IN) :: nc_name + INTEGER,INTENT(IN) :: pim,pjm + INTEGER,INTENT(IN) :: pitau0 + REAL,INTENT(IN) :: pdate0,pdeltat + INTEGER,INTENT(OUT) :: idf,phoriid + REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d + INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds + INTEGER,INTENT(IN),OPTIONAL :: domain_id + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!- + INTEGER :: nfid,iret,m_c + CHARACTER(LEN=120) :: file + CHARACTER(LEN=30) :: timenow + CHARACTER(LEN=11) :: c_nam + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (k_typ == 1) THEN + c_nam = 'histb_reg1d' + ELSEIF (k_typ == 2) THEN + c_nam = 'histb_reg2d' + ELSEIF (k_typ == 3) THEN + c_nam = 'histb_irreg' + ELSE + CALL ipslerr (3,"histbeg", & + & 'Illegal value of k_typ argument','in internal interface','?') + ENDIF +!- + IF (l_dbg) WRITE(*,*) c_nam//" 0.0" +!- +! Search for a free index +!- + idf = -1 + DO nfid=1,nb_files_max + IF (W_F(nfid)%ncfid < 0) THEN + idf = nfid; EXIT; + ENDIF + ENDDO + IF (idf < 0) THEN + CALL ipslerr (3,"histbeg", & + & 'Table of files too small. You should increase nb_files_max', & + & 'in histcom.f90 in order to accomodate all these files',' ') + ENDIF +!- +! 1.0 Transfering into the common for future use +!- + IF (l_dbg) WRITE(*,*) c_nam//" 1.0" +!- + W_F(idf)%itau0 = pitau0 + W_F(idf)%date0 = pdate0 + W_F(idf)%deltat = pdeltat +!- +! 2.0 Initializes all variables for this file +!- + IF (l_dbg) WRITE(*,*) c_nam//" 2.0" +!- + W_F(idf)%n_var = 0 + W_F(idf)%n_tax = 0 + W_F(idf)%n_hax = 0 + W_F(idf)%n_zax = 0 +!- + IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN + W_F(idf)%slab_ori(1:2) = (/ k_orx,k_ory /) + W_F(idf)%slab_siz(1:2) = (/ k_szx,k_szy /) + ELSE + W_F(idf)%slab_ori(1:2) = (/ 1,1 /) + W_F(idf)%slab_siz(1:2) = (/ pim,1 /) + ENDIF +!- +! 3.0 Opening netcdf file and defining dimensions +!- + IF (l_dbg) WRITE(*,*) c_nam//" 3.0" +!- +! Add DOMAIN number and ".nc" suffix in file name if needed +!- + file = nc_name + CALL flio_dom_file (file,domain_id) +!- +! Check the mode +!? See fliocom for HDF4 ???????????????????????????????????????????????? +!- + IF (PRESENT(mode)) THEN + SELECT CASE (TRIM(mode)) + CASE('32') + m_c = NF90_CLOBBER + CASE('64') + m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) + CASE DEFAULT + CALL ipslerr (3,"histbeg", & + & 'Invalid argument mode for file :',TRIM(file), & + & 'Supported values are 32 or 64') + END SELECT + ELSE + m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET) + ENDIF +!- + IF (PRESENT(snc4chunks)) THEN + IF (snc4chunks%luse) CALL get_nf90_symbol("NF90_HDF5", m_c) + ENDIF +!- +! Create file +!- + iret = NF90_CREATE(file,m_c,nfid) +!- + IF (k_typ == 1) THEN + iret = NF90_DEF_DIM(nfid,'lon',k_szx,W_F(idf)%xid) + iret = NF90_DEF_DIM(nfid,'lat',k_szy,W_F(idf)%yid) + ELSEIF (k_typ == 2) THEN + iret = NF90_DEF_DIM(nfid,'x',k_szx,W_F(idf)%xid) + iret = NF90_DEF_DIM(nfid,'y',k_szy,W_F(idf)%yid) + ELSEIF (k_typ == 3) THEN + iret = NF90_DEF_DIM(nfid,'x',pim,W_F(idf)%xid) + W_F(idf)%yid = W_F(idf)%xid + ENDIF +!- +! 4.0 Declaring the geographical coordinates and other attributes +!- + IF (l_dbg) WRITE(*,*) c_nam//" 4.0" +!- + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'Conventions','CF-1.1') + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'file_name',TRIM(file)) + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'production',TRIM(model_name)) + lock_modname = .TRUE. + CALL ioget_timestamp (timenow) + iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) +!- +! 5.0 Saving some important information on this file in the common +!- + IF (l_dbg) WRITE(*,*) c_nam//" 5.0" +!- + IF (PRESENT(domain_id)) THEN + W_F(idf)%dom_id_svg = domain_id + ENDIF + W_F(idf)%ncfid = nfid + IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN + W_F(idf)%full_size(1:2) = (/ pim,pjm /) + W_F(idf)%regular=.TRUE. + ELSEIF (k_typ == 3) THEN + W_F(idf)%full_size(1:2) = (/ pim,1 /) + W_F(idf)%regular=.FALSE. + ENDIF +!- +! 6.0 storing the geographical coordinates +!- + IF (k_typ == 1) THEN + CALL histh_all & + & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & + & x_1d=x_1d,y_1d=y_1d) + ELSEIF (k_typ == 2) THEN + CALL histh_all & + & (k_typ,idf,pim,pjm,' ','Default grid',phoriid, & + & x_2d=x_2d,y_2d=y_2d) + ELSEIF (k_typ == 3) THEN + CALL histh_all & + & (k_typ,idf,pim,pim,' ','Default grid',phoriid, & + & x_1d=x_1d,y_1d=y_1d,x_bnds=x_bnds,y_bnds=y_bnds) + ENDIF +!----------------------- +END SUBROUTINE histb_all +!=== +SUBROUTINE histh_reg1d & + & (idf,pim,plon,pjm,plat,phname,phtitle,phid) +!--------------------------------------------------------------------- +!- histhori for 1d regular grid (see histh_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pim,pjm + REAL,INTENT(IN),DIMENSION(:) :: plon,plat + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid +!--------------------------------------------------------------------- + CALL histh_all & + & (1,idf,pim,pjm,phname,phtitle,phid,x_1d=plon,y_1d=plat) +!------------------------- +END SUBROUTINE histh_reg1d +!=== +SUBROUTINE histh_reg2d & + & (idf,pim,plon,pjm,plat,phname,phtitle,phid) +!--------------------------------------------------------------------- +!- histhori for 2d regular grid (see histh_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pim,pjm + REAL,INTENT(IN),DIMENSION(:,:) :: plon,plat + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid +!--------------------------------------------------------------------- + CALL histh_all & + & (2,idf,pim,pjm,phname,phtitle,phid,x_2d=plon,y_2d=plat) +!------------------------- +END SUBROUTINE histh_reg2d +!=== +SUBROUTINE histh_irreg & + & (idf,pim,plon,plon_bounds,plat,plat_bounds,phname,phtitle,phid) +!--------------------------------------------------------------------- +!- histhori for irregular grid (see histh_all) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pim + REAL,DIMENSION(:),INTENT(IN) :: plon,plat + REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid +!--------------------------------------------------------------------- + CALL histh_all & + & (3,idf,pim,pim,phname,phtitle,phid, & + & x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds) +!------------------------- +END SUBROUTINE histh_irreg +!=== +SUBROUTINE histh_all & + & (k_typ,idf,pim,pjm,phname,phtitle,phid, & + & x_1d,y_1d,x_2d,y_2d,x_bnds,y_bnds) +!--------------------------------------------------------------------- +!- General interface for horizontal grids. +!- This subroutine is made to declare a new horizontal grid. +!- It has to have the same number of points as +!- the original and thus in this routine we will only +!- add two variable (longitude and latitude). +!- Any variable in the file can thus point to this pair +!- through an attribute. This routine is very usefull +!- to allow staggered grids. +!- +!- INPUT +!- +!- k_typ : Type of the grid (1 rectilinear, 2 regular, 3 irregular) +!- idf : The id of the file to which the grid should be added +!- pim : Size in the longitude direction +!- pjm : Size in the latitude direction (pjm=pim for type 3) +!- phname : The name of grid +!- phtitle : The title of the grid +!- +!- OUTPUT +!- +!- phid : Id of the created grid +!- +!- Optional INPUT arguments +!- +!- For rectilinear or irregular grid +!- x_1d : The longitudes +!- y_1d : The latitudes +!- For regular grid +!- x_2d : The longitudes +!- y_2d : The latitudes +!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied. +!- +!- For irregular grid. +!- x_bnds : The boundaries of the grid in longitude +!- y_bnds : The boundaries of the grid in latitude +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: k_typ + INTEGER,INTENT(IN) :: idf,pim,pjm + CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle + INTEGER,INTENT(OUT) :: phid + REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds +!- + CHARACTER(LEN=25) :: lon_name,lat_name + CHARACTER(LEN=30) :: lonbound_name,latbound_name + INTEGER :: i_s,i_e + INTEGER,DIMENSION(2) :: dims,dims_b + INTEGER :: nbbounds + INTEGER :: nlonidb,nlatidb,twoid + LOGICAL :: transp = .FALSE. + REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans + REAL :: wmn,wmx + INTEGER :: nlonid,nlatid + INTEGER :: o_x,o_y,s_x,s_y + INTEGER :: iret,nfid + CHARACTER(LEN=11) :: c_nam + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (k_typ == 1) THEN + c_nam = 'histh_reg1d' + ELSEIF (k_typ == 2) THEN + c_nam = 'histh_reg2d' + ELSEIF (k_typ == 3) THEN + c_nam = 'histh_irreg' + ELSE + CALL ipslerr (3,"histhori", & + & 'Illegal value of k_typ argument','in internal interface','?') + ENDIF +!- +! 1.0 Check that all fits in the buffers +!- + IF ( (pim /= W_F(idf)%full_size(1)) & + & .OR.(W_F(idf)%regular.AND.(pjm /= W_F(idf)%full_size(2))) & + & .OR.(.NOT.W_F(idf)%regular.AND.(W_F(idf)%full_size(2) /= 1)) ) THEN + CALL ipslerr (3,"histhori", & + & 'The new horizontal grid does not have the same size', & + & 'as the one provided to histbeg. This is not yet ', & + & 'possible in the hist package.') + ENDIF +!- +! 1.1 Create all the variables needed +!- + IF (l_dbg) WRITE(*,*) c_nam//" 1.0" +!- + nfid = W_F(idf)%ncfid +!- + IF (k_typ == 3) THEN + IF (SIZE(x_bnds,DIM=1) == pim) THEN + nbbounds = SIZE(x_bnds,DIM=2) + transp = .TRUE. + ELSEIF (SIZE(x_bnds,DIM=2) == pim) THEN + nbbounds = SIZE(x_bnds,DIM=1) + transp = .FALSE. + ELSE + CALL ipslerr (3,"histhori", & + & 'The boundary variable does not have any axis corresponding', & + & 'to the size of the longitude or latitude variable','.') + ENDIF + ALLOCATE(bounds_trans(nbbounds,pim)) + iret = NF90_DEF_DIM(nfid,'nbnd',nbbounds,twoid) + dims_b(1:2) = (/ twoid,W_F(idf)%xid /) + ENDIF +!- + dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) +!- + IF (k_typ == 1) THEN + IF (W_F(idf)%n_hax == 0) THEN + lon_name = 'lon' + lat_name = 'lat' + ELSE + lon_name = 'lon_'//TRIM(phname) + lat_name = 'lat_'//TRIM(phname) + ENDIF + ELSEIF (k_typ == 2) THEN + IF (W_F(idf)%n_hax == 0) THEN + lon_name = 'nav_lon' + lat_name = 'nav_lat' + ELSE + lon_name = 'nav_lon_'//TRIM(phname) + lat_name = 'nav_lat_'//TRIM(phname) + ENDIF + ELSEIF (k_typ == 3) THEN + IF (W_F(idf)%n_hax == 0) THEN + lon_name = 'nav_lon' + lat_name = 'nav_lat' + ELSE + lon_name = 'nav_lon_'//TRIM(phname) + lat_name = 'nav_lat_'//TRIM(phname) + ENDIF + lonbound_name = TRIM(lon_name)//'_bounds' + latbound_name = TRIM(lat_name)//'_bounds' + ENDIF +!- +! 1.2 Save the informations +!- + phid = W_F(idf)%n_hax+1 + W_F(idf)%n_hax = phid + W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /) +!- +! 2.0 Longitude +!- + IF (l_dbg) WRITE(*,*) c_nam//" 2.0" +!- + i_s = 1; + IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN + i_e = 1; wmn = MINVAL(x_1d); wmx = MAXVAL(x_1d); + ELSEIF (k_typ == 2) THEN + i_e = 2; wmn = MINVAL(x_2d); wmx = MAXVAL(x_2d); + ENDIF + iret = NF90_DEF_VAR(nfid,lon_name,NF90_REAL4,dims(i_s:i_e),nlonid) + IF (k_typ == 1) THEN + iret = NF90_PUT_ATT(nfid,nlonid,'axis',"X") + ENDIF + iret = NF90_PUT_ATT(nfid,nlonid,'standard_name',"longitude") + iret = NF90_PUT_ATT(nfid,nlonid,'units',"degrees_east") + iret = NF90_PUT_ATT(nfid,nlonid,'valid_min',REAL(wmn,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlonid,'valid_max',REAL(wmx,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlonid,'long_name',"Longitude") + iret = NF90_PUT_ATT(nfid,nlonid,'nav_model',TRIM(phtitle)) +!- + IF (k_typ == 3) THEN +!--- +!-- 2.1 Longitude bounds +!--- + iret = NF90_PUT_ATT(nfid,nlonid,'bounds',TRIM(lonbound_name)) + iret = NF90_DEF_VAR(nfid,lonbound_name,NF90_REAL4,dims_b(1:2),nlonidb) + iret = NF90_PUT_ATT(nfid,nlonidb,'long_name', & + & 'Boundaries for coordinate variable '//TRIM(lon_name)) + ENDIF +!- +! 3.0 Latitude +!- + IF (l_dbg) WRITE(*,*) c_nam//" 3.0" +!- + i_e = 2; + IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN + i_s = 2; wmn = MINVAL(y_1d); wmx = MAXVAL(y_1d); + ELSEIF (k_typ == 2) THEN + i_s = 1; wmn = MINVAL(y_2d); wmx = MAXVAL(y_2d); + ENDIF + iret = NF90_DEF_VAR(nfid,lat_name,NF90_REAL4,dims(i_s:i_e),nlatid) + IF (k_typ == 1) THEN + iret = NF90_PUT_ATT(nfid,nlatid,'axis',"Y") + ENDIF +!- + iret = NF90_PUT_ATT(nfid,nlatid,'standard_name',"latitude") + iret = NF90_PUT_ATT(nfid,nlatid,'units',"degrees_north") + iret = NF90_PUT_ATT(nfid,nlatid,'valid_min',REAL(wmn,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlatid,'valid_max',REAL(wmx,KIND=4)) + iret = NF90_PUT_ATT(nfid,nlatid,'long_name',"Latitude") + iret = NF90_PUT_ATT(nfid,nlatid,'nav_model',TRIM(phtitle)) +!- + IF (k_typ == 3) THEN +!--- +!-- 3.1 Latitude bounds +!--- + iret = NF90_PUT_ATT(nfid,nlatid,'bounds',TRIM(latbound_name)) + iret = NF90_DEF_VAR(nfid,latbound_name,NF90_REAL4,dims_b(1:2),nlatidb) + iret = NF90_PUT_ATT(nfid,nlatidb,'long_name', & + & 'Boundaries for coordinate variable '//TRIM(lat_name)) + ENDIF +!- + iret = NF90_ENDDEF(nfid) +!- +! 4.0 storing the geographical coordinates +!- + IF (l_dbg) WRITE(*,*) c_nam//" 4.0" +!- + IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN + o_x = W_F(idf)%slab_ori(1) + o_y = W_F(idf)%slab_ori(2) + s_x = W_F(idf)%slab_siz(1) + s_y = W_F(idf)%slab_siz(2) +!--- +!-- Transfer the longitude and the latitude +!--- + IF (k_typ == 1) THEN + iret = NF90_PUT_VAR(nfid,nlonid,x_1d(o_x:o_x+s_x-1)) + iret = NF90_PUT_VAR(nfid,nlatid,y_1d(o_y:o_y+s_y-1)) + ELSEIF (k_typ == 2) THEN + iret = NF90_PUT_VAR(nfid,nlonid, & + & x_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) + iret = NF90_PUT_VAR(nfid,nlatid, & + & y_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1)) + ENDIF + ELSEIF (k_typ == 3) THEN +!--- +!-- Transfer the longitude and the longitude bounds +!--- + iret = NF90_PUT_VAR(nfid,nlonid,x_1d(1:pim)) +!--- + IF (transp) THEN + bounds_trans = TRANSPOSE(x_bnds) + ELSE + bounds_trans = x_bnds + ENDIF + iret = NF90_PUT_VAR(nfid,nlonidb,bounds_trans(1:nbbounds,1:pim)) +!--- +!-- Transfer the latitude and the latitude bounds +!--- + iret = NF90_PUT_VAR(nfid,nlatid,y_1d(1:pim)) +!--- + IF (transp) THEN + bounds_trans = TRANSPOSE(y_bnds) + ELSE + bounds_trans = y_bnds + ENDIF + iret = NF90_PUT_VAR(nfid,nlatidb,bounds_trans(1:nbbounds,1:pim)) +!--- + DEALLOCATE(bounds_trans) + ENDIF +!- + iret = NF90_REDEF(nfid) +!----------------------- +END SUBROUTINE histh_all +!=== +SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, & + & pzsize,pzvalues,pzaxid,pdirect) +!--------------------------------------------------------------------- +!- This subroutine defines a vertical axis and returns it s id. +!- It gives the user the possibility to the user to define many +!- different vertical axes. For each variable defined with histdef a +!- vertical axis can be specified with by it s ID. +!- +!- INPUT +!- +!- idf : ID of the file the variable should be archived in +!- pzaxname : Name of the vertical axis +!- pzaxtitle: title of the vertical axis +!- pzaxunit : Units of the vertical axis (no units if blank string) +!- pzsize : size of the vertical axis +!- pzvalues : Coordinate values of the vetical axis +!- +!- pdirect : is an optional argument which allows to specify the +!- the positive direction of the axis : up or down. +!- OUTPUT +!- +!- pzaxid : Returns the ID of the axis. +!- Note that this is not the netCDF ID ! +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pzsize + CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle + REAL,INTENT(IN) :: pzvalues(pzsize) + INTEGER,INTENT(OUT) :: pzaxid + CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: pdirect +!- + INTEGER :: pos,iv,zdimid,zaxid_tmp + CHARACTER(LEN=70) :: str71 + CHARACTER(LEN=20) :: direction + INTEGER :: iret,leng,nfid + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Verifications : +! Do we have enough space for an extra axis ? +! Is the name already in use ? +!- + IF (l_dbg) WRITE(*,*) "histvert : 1.0 Verifications", & + & pzaxname,'---',pzaxunit,'---',pzaxtitle +!- +! Direction of the vertical axis. Can we get if from the user. +!- + IF (PRESENT(pdirect)) THEN + direction = TRIM(pdirect) + CALL strlowercase (direction) + ELSE + direction = 'unknown' + ENDIF +!- +! Check the consistency of the attribute +!- + IF ( PRESENT(pdirect) & + & .AND.(direction /= 'up') & + & .AND.(direction /= 'down') ) THEN + direction = 'unknown' + CALL ipslerr (2,"histvert",& + & "The specified positive direction for the vertical axis is invalid.",& + & "The value must be up or down.","The attribute will not be written.") + ENDIF +!- + IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN + CALL ipslerr (3,"histvert", & + & 'Table of vertical axes too small. You should increase ',& + & 'nb_zax_max in histcom.f90 in order to accomodate all ', & + & 'these variables ') + ENDIF +!- + iv = W_F(idf)%n_zax + IF (iv > 1) THEN + CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos) + ELSE + pos = 0 + ENDIF +!- + IF (pos > 0) THEN + WRITE(str71,'("Check variable ",A," in file",I3)') & + & TRIM(pzaxname),idf + CALL ipslerr (3,"histvert", & + & "Vertical axis already exists",TRIM(str71), & + & "Can also be a wrong file ID in another declaration") + ENDIF +!- + iv = W_F(idf)%n_zax+1 +!- +! 2.0 Add the information to the file +!- + IF (l_dbg) & + & WRITE(*,*) "histvert : 2.0 Add the information to the file" +!- + nfid = W_F(idf)%ncfid +!- + leng = MIN(LEN_TRIM(pzaxname),20) + iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp) + iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_REAL4, & + & zaxid_tmp,zdimid) + iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z") + iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number") + leng = MIN(LEN_TRIM(pzaxunit),20) + IF (leng > 0) THEN + iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng)) + ENDIF + IF (direction /= 'unknown') THEN + iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction)) + ENDIF + iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', & + & REAL(MINVAL(pzvalues(1:pzsize)),KIND=4)) + iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', & + & REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4)) + leng = MIN(LEN_TRIM(pzaxname),20) + iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng)) + leng = MIN(LEN_TRIM(pzaxtitle),80) + iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng)) +!- + iret = NF90_ENDDEF (nfid) +!- + iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize)) +!- + iret = NF90_REDEF (nfid) +!- +!- 3.0 add the information to the common +!- + IF (l_dbg) & + & WRITE(*,*) "histvert : 3.0 add the information to the common" +!- + W_F(idf)%n_zax = iv + W_F(idf)%zax_size(iv) = pzsize + W_F(idf)%zax_name(iv) = pzaxname + W_F(idf)%zax_ids(iv) = zaxid_tmp + pzaxid = iv +!---------------------- +END SUBROUTINE histvert +!=== +SUBROUTINE histdef & + & (idf,pvarname,ptitle,punit, & + & pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, & + & xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name) +!--------------------------------------------------------------------- +!- With this subroutine each variable to be archived on the history +!- tape should be declared. +!- +!- It gives the user the choise of operation +!- to be performed on the variables, the frequency of this operation +!- and finaly the frequency of the archiving. +!- +!- INPUT +!- +!- idf : ID of the file the variable should be archived in +!- pvarname : Name of the variable, short and easy to remember +!- ptitle : Full name of the variable +!- punit : Units of the variable (no units if blank string) +!- +!- The next 3 arguments give the size of that data +!- that will be passed to histwrite. The zoom will be +!- done there with the horizontal information obtained +!- in histbeg and the vertical information to follow. +!- +!- pxsize : Size in X direction (size of the data that will be +!- given to histwrite) +!- pysize : Size in Y direction +!- phoriid : ID of the horizontal axis +!- +!- The next two arguments give the vertical zoom to use. +!- +!- pzsize : Size in Z direction (If 1 then no axis is declared +!- for this variable and pzid is not used) +!- par_oriz : Off set of the zoom +!- par_szz : Size of the zoom +!- +!- pzid : ID of the vertical axis to use. It has to have +!- the size of the zoom. +!- xtype : External netCDF type (hist_r4/hist_r8) +!- popp : Operation to be performed. The following options +!- exist today : +!- inst : keeps instantaneous values for writting +!- ave : Computes the average from call between writes +!- pfreq_opp: Frequency of this operation (in seconds) +!- pfreq_wrt: Frequency at which the variable should be +!- written (in seconds) +!- var_range: Range of the variable. +!- If the minimum is greater than the maximum, +!- the values will be calculated. +!- +!- VERSION +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid + INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid + CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle + REAL,INTENT(IN) :: pfreq_opp,pfreq_wrt + REAL,DIMENSION(2),OPTIONAL,INTENT(IN) :: var_range + CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name +!- + INTEGER :: iv + CHARACTER(LEN=70) :: str70,str71,str72 + CHARACTER(LEN=20) :: tmp_name + CHARACTER(LEN=40) :: str40 + CHARACTER(LEN=10) :: str10 + CHARACTER(LEN=120) :: ex_topps + REAL :: un_an,un_jour,test_fopp,test_fwrt + INTEGER :: pos,buff_sz + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min' +!- + W_F(idf)%n_var = W_F(idf)%n_var+1 + iv = W_F(idf)%n_var +!- + IF (iv > nb_var_max) THEN + CALL ipslerr (3,"histdef", & + & 'Table of variables too small. You should increase nb_var_max',& + & 'in histcom.f90 in order to accomodate all these variables', & + & ' ') + ENDIF +!- +! 1.0 Transfer informations on the variable to the common +! and verify that it does not already exist +!- + IF (l_dbg) WRITE(*,*) "histdef : 1.0" +!- + IF (iv > 1) THEN + CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos) + ELSE + pos = 0 + ENDIF +!- + IF (pos > 0) THEN + str70 = "Variable already exists" + WRITE(str71,'("Check variable ",a," in file",I3)') & + & TRIM(pvarname),idf + str72 = "Can also be a wrong file ID in another declaration" + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- + W_F(idf)%W_V(iv)%v_name = pvarname + W_F(idf)%W_V(iv)%title = ptitle + W_F(idf)%W_V(iv)%unit_name = punit + IF (PRESENT(standard_name)) THEN + W_F(idf)%W_V(iv)%std_name = standard_name + ELSE + W_F(idf)%W_V(iv)%std_name = ptitle + ENDIF + tmp_name = W_F(idf)%W_V(iv)%v_name +!- +! 1.1 decode the operations +!- + W_F(idf)%W_V(iv)%fullop = popp + CALL buildop & + & (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, & + & W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, & + & W_F(idf)%W_V(iv)%nbopp) +!- +! 1.2 If we have an even number of operations +! then we need to add identity +!- + IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN + W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1 + W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident' + W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val + ENDIF +!- +! 1.3 External type of the variable +!- + IF (xtype == hist_r8) THEN + W_F(idf)%W_V(iv)%v_typ = hist_r8 + ELSE + W_F(idf)%W_V(iv)%v_typ = hist_r4 + ENDIF +!- +! 2.0 Put the size of the variable in the common and check +!- + IF (l_dbg) THEN + WRITE(*,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, & + & W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), & + & W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp) + ENDIF +!- + W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /) + W_F(idf)%W_V(iv)%zorig(1:3) = & + & (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /) + W_F(idf)%W_V(iv)%zsize(1:3) = & + & (/ W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2),par_szz /) +!- +! Is the size of the full array the same as that of the coordinates ? +!- + IF ( (pxsize > W_F(idf)%full_size(1)) & + & .OR.(pysize > W_F(idf)%full_size(2)) ) THEN +!- + str70 = "The size of the variable is different "// & + & "from the one of the coordinates" + WRITE(str71,'("Size of coordinates :",2I4)') & + & W_F(idf)%full_size(1),W_F(idf)%full_size(2) + WRITE(str72,'("Size declared for variable ",a," :",2I4)') & + & TRIM(tmp_name),pxsize,pysize + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +! Is the size of the zoom smaller than the coordinates ? +!- + IF ( (W_F(idf)%full_size(1) < W_F(idf)%slab_siz(1)) & + & .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_siz(2)) ) THEN + str70 = & + & "Size of variable should be greater or equal to those of the zoom" + WRITE(str71,'("Size of XY zoom :",2I4)') & + & W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2) + WRITE(str72,'("Size declared for variable ",A," :",2I4)') & + & TRIM(tmp_name),pxsize,pysize + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +! 2.1 We store the horizontal grid information with minimal +! and a fall back onto the default grid +!- + IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN + W_F(idf)%W_V(iv)%h_axid = phoriid + ELSE + W_F(idf)%W_V(iv)%h_axid = 1 + CALL ipslerr (2,"histdef", & + & 'We use the default grid for variable as an invalide',& + & 'ID was provided for variable : ',TRIM(pvarname)) + ENDIF +!- +! 2.2 Check the vertical coordinates if needed +!- + IF (par_szz > 1) THEN +!- +!-- Does the vertical coordinate exist ? +!- + IF (pzid > W_F(idf)%n_zax) THEN + WRITE(str70, & + & '("The vertical coordinate chosen for variable ",A)') & + & TRIM(tmp_name) + str71 = " Does not exist." + CALL ipslerr (3,"histdef",str70,str71," ") + ENDIF +!- +!-- Is the vertical size of the variable equal to that of the axis ? +!- + IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN + str70 = "The size of the zoom does not correspond "// & + & "to the size of the chosen vertical axis" + WRITE(str71,'("Size of zoom in z :",I4)') par_szz + WRITE(str72,'("Size declared for axis ",A," :",I4)') & + & TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid) + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +!-- Is the zoom smaller that the total size of the variable ? +!- + IF (pzsize < par_szz) THEN + str70 = "The vertical size of variable "// & + & "is smaller than that of the zoom." + WRITE(str71,'("Declared vertical size of data :",I5)') pzsize + WRITE(str72,'("Size of zoom for variable ",a," = ",I5)') & + & TRIM(tmp_name),par_szz + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF + W_F(idf)%W_V(iv)%z_axid = pzid + ELSE + W_F(idf)%W_V(iv)%z_axid = -99 + ENDIF +!- +! 3.0 We get the size of the arrays histwrite will get +! and eventually allocate the time_buffer +!- + IF (l_dbg) THEN + WRITE(*,*) "histdef : 3.0" + ENDIF +!- + buff_sz = W_F(idf)%W_V(iv)%zsize(1) & + & *W_F(idf)%W_V(iv)%zsize(2) & + & *W_F(idf)%W_V(iv)%zsize(3) +!- + IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN + ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz)) + W_F(idf)%W_V(iv)%t_bf(:) = 0. + IF (l_dbg) THEN + WRITE(*,*) "histdef : 3.0 allocating time_buffer for", & + & " idf = ",idf," iv = ",iv," size = ",buff_sz + ENDIF + ENDIF +!- +! 4.0 Transfer the frequency of the operations and check +! for validity. We have to pay attention to negative values +! of the frequency which indicate monthly time-steps. +! The strategy is to bring it back to seconds for the tests +!- + IF (l_dbg) WRITE(*,*) "histdef : 4.0" +!- + W_F(idf)%W_V(iv)%freq_opp = pfreq_opp + W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt +!- + CALL ioget_calendar(un_an,un_jour) + IF (pfreq_opp < 0) THEN + CALL ioget_calendar(un_an) + test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour + ELSE + test_fopp = pfreq_opp + ENDIF + IF (pfreq_wrt < 0) THEN + CALL ioget_calendar(un_an) + test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour + ELSE + test_fwrt = pfreq_wrt + ENDIF +!- +! 4.1 Frequency of operations and output should be larger than deltat ! +!- + IF (test_fopp < W_F(idf)%deltat) THEN + str70 = 'Frequency of operations should be larger than deltat' + WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & + & TRIM(tmp_name),pfreq_opp + str72 = "PATCH : frequency set to deltat" +!- + CALL ipslerr (2,"histdef",str70,str71,str72) +!- + W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat + ENDIF +!- + IF (test_fwrt < W_F(idf)%deltat) THEN + str70 = 'Frequency of output should be larger than deltat' + WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') & + & TRIM(tmp_name),pfreq_wrt + str72 = "PATCH : frequency set to deltat" +!- + CALL ipslerr (2,"histdef",str70,str71,str72) +!- + W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat + ENDIF +!- +! 4.2 First the existence of the operation is tested and then +! its compaticility with the choice of frequencies +!- + IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN + IF (test_fopp /= test_fwrt) THEN + str70 = 'For instantaneous output the frequency '// & + & 'of operations and output' + WRITE(str71, & + & '("should be the same, this was not case for variable ",a)') & + & TRIM(tmp_name) + str72 = "PATCH : The smalest frequency of both is used" + CALL ipslerr (2,"histdef",str70,str71,str72) + IF (test_fopp < test_fwrt) THEN + W_F(idf)%W_V(iv)%freq_opp = pfreq_opp + W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp + ELSE + W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt + W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt + ENDIF + ENDIF + ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN + IF (test_fopp > test_fwrt) THEN + str70 = 'For averages the frequency of operations '// & + & 'should be smaller or equal' + WRITE(str71, & + & '("to that of output. It is not the case for variable ",a)') & + & TRIM(tmp_name) + str72 = 'PATCH : The output frequency is used for both' + CALL ipslerr (2,"histdef",str70,str71,str72) + W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt + ENDIF + ELSE + WRITE (str70,'("Operation on variable ",A," is unknown")') & + & TRIM(tmp_name) + WRITE (str71,'("operation requested is :",A)') & + & W_F(idf)%W_V(iv)%topp + WRITE (str72,'("File ID :",I3)') idf + CALL ipslerr (3,"histdef",str70,str71,str72) + ENDIF +!- +! 5.0 Initialize other variables of the common +!- + IF (l_dbg) WRITE(*,*) "histdef : 5.0" +!- + W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range)) + IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN + W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2)) + IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN + W_F(idf)%W_V(iv)%hist_minmax(1:2) = & + & (/ ABS(missing_val),-ABS(missing_val) /) + ELSE + W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2) + ENDIF + ENDIF +!- +! - freq_opp(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0 +! - freq_wrt(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0 +! - freq_opp(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0 +! - freq_wrt(idf,iv)/2./deltat(idf) + W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0 + W_F(idf)%W_V(iv)%nb_opp = 0 + W_F(idf)%W_V(iv)%nb_wrt = 0 +!- +! 6.0 Get the time axis for this variable +!- + IF (l_dbg) WRITE(*,*) "histdef : 6.0" +!- +! No time axis for once, l_max, l_min or never operation +!- + IF ( (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once') & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') & + & .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN + IF (TRIM(W_F(idf)%W_V(iv)%topp) == 'inst') THEN + str10 = 't_inst_' + ELSE + str10 = 't_op_' + ENDIF + IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN + WRITE (UNIT=str40,FMT='(A,I8.8)') & +& TRIM(str10),INT(W_F(idf)%W_V(iv)%freq_wrt) + ELSE + WRITE (UNIT=str40,FMT='(A,I2.2,"month")') & +& TRIM(str10),ABS(INT(W_F(idf)%W_V(iv)%freq_wrt)) + ENDIF + CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos) + IF (pos < 0) THEN + W_F(idf)%n_tax = W_F(idf)%n_tax+1 + W_F(idf)%W_V(iv)%l_bnd = & + & (TRIM(W_F(idf)%W_V(iv)%topp) /= 'inst') + W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40 + W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0 + W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax + ELSE + W_F(idf)%W_V(iv)%t_axid = pos + ENDIF + ELSE + IF (l_dbg) THEN + WRITE(*,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----' + ENDIF + W_F(idf)%W_V(iv)%t_axid = -99 + ENDIF +!- +! 7.0 prepare frequence of writing and operation +! for never or once operation +!- + IF ( (TRIM(W_F(idf)%W_V(iv)%topp) == 'once') & + & .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN + W_F(idf)%W_V(iv)%freq_opp = 0. + W_F(idf)%W_V(iv)%freq_wrt = 0. + ENDIF +!--------------------- +END SUBROUTINE histdef +!=== +SUBROUTINE histend (idf, snc4chunks) +!--------------------------------------------------------------------- +!- This subroutine end the decalaration of variables and sets the +!- time axes in the netcdf file and puts it into the write mode. +!- +!- INPUT +!- +!- idf : ID of the file to be worked on +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf + TYPE(snc4_ctl), OPTIONAL,INTENT(IN) :: snc4chunks +!- + INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt + INTEGER,DIMENSION(4) :: dims + INTEGER :: year,month,day,hours,minutes + REAL :: sec + REAL :: rtime0 + CHARACTER(LEN=30) :: str30 + CHARACTER(LEN=35) :: str35 + CHARACTER(LEN=120) :: assoc + CHARACTER(LEN=70) :: str70 + CHARACTER(LEN=3),DIMENSION(12) :: cal = & + & (/ 'JAN','FEB','MAR','APR','MAY','JUN', & + & 'JUL','AUG','SEP','OCT','NOV','DEC' /) + CHARACTER(LEN=7) :: tmp_opp + LOGICAL :: l_b + LOGICAL :: l_dbg + INTEGER, DIMENSION(4) :: ichunksz ! NETCDF4 chunk sizes + INTEGER :: ichunkalg, ishuffle,& + ideflate, ideflate_level + LOGICAL :: lchunk = .FALSE. ! logical switch to activate chunking when appropriate +!- + ! NetCDF4 chunking and compression parameters + ichunkalg = 0 + ishuffle = 1 + ideflate = 1 + ideflate_level = 1 + ! +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + nfid = W_F(idf)%ncfid +!- +! 1.0 Create the time axes +!- + IF (l_dbg) WRITE(*,*) "histend : 1.0" +!- +! 1.1 Define the time dimensions needed for this file +!- + iret = NF90_DEF_DIM (nfid,'time_counter', & + & NF90_UNLIMITED,W_F(idf)%tid) + DO iv=1,W_F(idf)%n_var + IF (W_F(idf)%W_V(iv)%l_bnd) THEN + iret = NF90_DEF_DIM (nfid,'tbnds',2,W_F(idf)%bid) + EXIT + ENDIF + ENDDO +!- +! 1.2 Define all the time axes needed for this file +!- + DO itx=1,W_F(idf)%n_tax + dims(1) = W_F(idf)%tid + l_b = (INDEX(W_F(idf)%W_V(itx)%tax_name,"t_op_") == 1) + IF (itx > 1) THEN + str30 = W_F(idf)%W_V(itx)%tax_name + ELSE + str30 = "time_counter" + ENDIF + IF (l_b) THEN + str35 = TRIM(str30)//'_bnds' + ENDIF + iret = NF90_DEF_VAR (nfid,TRIM(str30),NF90_REAL8, & + & dims(1),W_F(idf)%W_V(itx)%tdimid) + IF (itx <= 1) THEN + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T") + ENDIF + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'standard_name',"time") +!--- +! To transform the current itau into a real date and take it +! as the origin of the file requires the time counter to change. +! Thus it is an operation the user has to ask for. +! This function should thus only be re-instated +! if there is a ioconf routine to control it. +!--- +!-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf)) + rtime0 = W_F(idf)%date0 +!- + CALL ju2ymds(rtime0,year,month,day,sec) +!--- +! Catch any error induced by a change in calendar ! +!--- + IF (year < 0) THEN + year = 2000+year + ENDIF +!- + hours = INT(sec/(60.*60.)) + minutes = INT((sec-hours*60.*60.)/60.) + sec = sec-(hours*60.*60.+minutes*60.) +!- + WRITE (UNIT=str70, & + & FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & + & 'seconds since ',year,month,day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'units',TRIM(str70)) +!- + CALL ioget_calendar (str30) + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'calendar',TRIM(str30)) +!- + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'title','Time') +!- + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'long_name','Time axis') +!- + WRITE (UNIT=str70, & + & FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') & + & year,cal(month),day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'time_origin',TRIM(str70)) +!--- + IF (l_b) THEN + iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, & + & 'bounds',TRIM(str35)) + dims(1:2) = (/ W_F(idf)%bid,W_F(idf)%tid /) + iret = NF90_DEF_VAR (nfid,TRIM(str35),NF90_REAL8, & + & dims(1:2),W_F(idf)%W_V(itx)%tbndid) + ENDIF + ENDDO +!- +! 2.0 declare the variables +!- + IF (l_dbg) WRITE(*,*) "histend : 2.0" +!- + DO iv=1,W_F(idf)%n_var +!--- + itax = W_F(idf)%W_V(iv)%t_axid +!--- + IF (W_F(idf)%regular) THEN + dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /) + dim_cnt = 2 + ELSE + dims(1) = W_F(idf)%xid + dim_cnt = 1 + ENDIF +!--- + tmp_opp = W_F(idf)%W_V(iv)%topp + ziv = W_F(idf)%W_V(iv)%z_axid +!--- +! 2.1 dimension of field +!--- + IF ((TRIM(tmp_opp) /= 'never')) THEN + IF ( (TRIM(tmp_opp) /= 'once') & + & .AND.(TRIM(tmp_opp) /= 'l_max') & + & .AND.(TRIM(tmp_opp) /= 'l_min') ) THEN + IF (ziv == -99) THEN + ndim = dim_cnt+1 + dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /) + ELSE + ndim = dim_cnt+2 + dims(dim_cnt+1:dim_cnt+2) = & + & (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /) + ENDIF + ELSE + IF (ziv == -99) THEN + ndim = dim_cnt + dims(dim_cnt+1:dim_cnt+2) = (/ 0,0 /) + ELSE + ndim = dim_cnt+1 + dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /) + ENDIF + ENDIF +!- + iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), & + & W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid) +!- + IF( ndim == 4 ) THEN + IF( PRESENT( snc4chunks ) ) THEN + IF( snc4chunks%luse ) THEN + ichunksz = 1 + iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%xid, len = ichunksz(1) ) + iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%yid, len = ichunksz(2) ) + IF ( ziv .NE. -99 ) & + iret = NF90_INQUIRE_DIMENSION( nfid, W_F(idf)%zax_ids(ziv), len = ichunksz(3) ) + ichunksz(1) = MIN(ichunksz(1), MAX((ichunksz(1)-1)/snc4chunks%ni + 1,16)) + ichunksz(2) = MIN(ichunksz(2), MAX((ichunksz(2)-1)/snc4chunks%nj + 1,16)) + ichunksz(3) = MIN(ichunksz(3), MAX((ichunksz(3)-1)/snc4chunks%nk + 1, 1)) + ! Always use a chunk size of 1 for the unlimited dimension + iret = SET_NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) + iret = SET_NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) + ENDIF + ENDIF + ENDIF + W_F(idf)%W_V(iv)%ncvid = nvid +!- + IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN + iret = NF90_PUT_ATT (nfid,nvid,'units', & + & TRIM(W_F(idf)%W_V(iv)%unit_name)) + ENDIF + iret = NF90_PUT_ATT (nfid,nvid,'standard_name', & + & TRIM(W_F(idf)%W_V(iv)%std_name)) +!- + IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN + iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL8) + ELSE + iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL4) + ENDIF + IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN + IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN + iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=8)) + iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=8)) + ELSE + iret = NF90_PUT_ATT (nfid,nvid,'valid_min', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4)) + iret = NF90_PUT_ATT (nfid,nvid,'valid_max', & + & REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4)) + ENDIF + ENDIF + iret = NF90_PUT_ATT (nfid,nvid,'long_name', & + & TRIM(W_F(idf)%W_V(iv)%title)) + iret = NF90_PUT_ATT (nfid,nvid,'online_operation', & + & TRIM(W_F(idf)%W_V(iv)%fullop)) +!- + SELECT CASE(ndim) + CASE(-3,2:4) + CASE DEFAULT + CALL ipslerr (3,"histend", & + & 'less than 2 or more than 4 dimensions are not', & + & 'allowed at this stage',' ') + END SELECT +!- + assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) & + & //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1)) +!- + ziv = W_F(idf)%W_V(iv)%z_axid + IF (ziv > 0) THEN + str30 = W_F(idf)%zax_name(ziv) + assoc = TRIM(str30)//' '//TRIM(assoc) + ENDIF +!- + IF (itax > 0) THEN + IF (itax > 1) THEN + str30 = W_F(idf)%W_V(itax)%tax_name + ELSE + str30 = "time_counter" + ENDIF + assoc = TRIM(str30)//' '//TRIM(assoc) +!- + IF (l_dbg) THEN + WRITE(*,*) "histend : 2.0.n, freq_opp, freq_wrt", & + & W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt + ENDIF +!- + iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', & + & REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4)) + iret = NF90_PUT_ATT (nfid,nvid,'interval_write', & + & REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4)) + ENDIF + iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc)) + ENDIF + ENDDO +!- +! 2.2 Add DOMAIN attributes if needed +!- + IF (W_F(idf)%dom_id_svg >= 0) THEN + CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg) + ENDIF +!- +! 3.0 Put the netcdf file into write mode +!- + IF (l_dbg) WRITE(*,*) "histend : 3.0" +!- + iret = NF90_ENDDEF (nfid) +!- +! 4.0 Give some informations to the user +!- + IF (l_dbg) WRITE(*,*) "histend : 4.0" +!- +!!$ WRITE(str70,'("All variables have been initialized on file :",I3)') idf +!!$ CALL ipslerr (1,'histend',str70,'',' ') +!--------------------- +END SUBROUTINE histend +!=== +SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + REAL,DIMENSION(:),INTENT(IN) :: pdata + CHARACTER(LEN=*),INTENT(IN) :: pvarname +!--------------------------------------------------------------------- + CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata) +!--------------------------- +END SUBROUTINE histwrite_r1d +!=== +SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + REAL,DIMENSION(:,:),INTENT(IN) :: pdata + CHARACTER(LEN=*),INTENT(IN) :: pvarname +!--------------------------------------------------------------------- + CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata) +!--------------------------- +END SUBROUTINE histwrite_r2d +!=== +SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata + CHARACTER(LEN=*),INTENT(IN) :: pvarname +!--------------------------------------------------------------------- + CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata) +!--------------------------- +END SUBROUTINE histwrite_r3d +!=== +SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, & + & pdata_1d,pdata_2d,pdata_3d) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,nbindex + INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex + CHARACTER(LEN=*),INTENT(IN) :: pvarname + REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: pdata_1d + REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: pdata_2d + REAL,DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: pdata_3d +!- + LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d + INTEGER :: iv,io,nbpt_out + INTEGER :: nbpt_in1 + INTEGER,DIMENSION(2) :: nbpt_in2 + INTEGER,DIMENSION(3) :: nbpt_in3 + REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1 + CHARACTER(LEN=7) :: tmp_opp + CHARACTER(LEN=13) :: c_nam + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + l1d=PRESENT(pdata_1d); l2d=PRESENT(pdata_2d); l3d=PRESENT(pdata_3d); + IF (l1d) THEN + c_nam = 'histwrite_r1d' + ELSE IF (l2d) THEN + c_nam = 'histwrite_r2d' + ELSE IF (l3d) THEN + c_nam = 'histwrite_r3d' + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite : ",c_nam + ENDIF +!- +! 1.0 Try to catch errors like specifying the wrong file ID. +! Thanks Marine for showing us what errors users can make ! +!- + IF ( (idf < 1).OR.(idf > nb_files_max) ) THEN + CALL ipslerr (3,"histwrite", & + & 'Illegal file ID in the histwrite of variable',pvarname,' ') + ENDIF +!- +! 1.1 Find the id of the variable to be written and the real time +!- + CALL histvar_seq (idf,pvarname,iv) +!- +! 2.0 do nothing for never operation +!- + tmp_opp = W_F(idf)%W_V(iv)%topp +!- + IF (TRIM(tmp_opp) == "never") THEN + W_F(idf)%W_V(iv)%last_opp_chk = -99 + W_F(idf)%W_V(iv)%last_wrt_chk = -99 + ENDIF +!- +! 3.0 We check if we need to do an operation +!- + IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN + CALL ipslerr (3,"histwrite", & + & 'This variable has already been analysed at the present', & + & 'time step',TRIM(pvarname)) + ENDIF +!- + CALL isittime & + & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & + & W_F(idf)%W_V(iv)%freq_opp, & + & W_F(idf)%W_V(iv)%last_opp, & + & W_F(idf)%W_V(iv)%last_opp_chk,do_oper) +!- +! 4.0 We check if we need to write the data +!- + IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN + CALL ipslerr (3,"histwrite", & + & 'This variable as already been written for the present', & + & 'time step',' ') + ENDIF +!- + CALL isittime & + & (pitau,W_F(idf)%date0,W_F(idf)%deltat, & + & W_F(idf)%W_V(iv)%freq_wrt, & + & W_F(idf)%W_V(iv)%last_wrt, & + & W_F(idf)%W_V(iv)%last_wrt_chk,do_write) +!- +! 5.0 histwrite called +!- + IF (do_oper.OR.do_write) THEN +!- +!-- 5.1 Get the sizes of the data we will handle +!- + IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN +!---- There is the risk here that the user has over-sized the array. +!---- But how can we catch this ? +!---- In the worst case we will do impossible operations +!---- on part of the data ! + W_F(idf)%W_V(iv)%datasz_in(1:3) = -1 + IF (l1d) THEN + W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d) + ELSE IF (l2d) THEN + W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1) + W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2) + ELSE IF (l3d) THEN + W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1) + W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2) + W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3) + ENDIF + ENDIF +!- +!-- 5.2 The maximum size of the data will give the size of the buffer +!- + IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN + largebuf = .FALSE. + DO io=1,W_F(idf)%W_V(iv)%nbopp + IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN + largebuf = .TRUE. + ENDIF + ENDDO + IF (largebuf) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%scsize(1) & + & *W_F(idf)%W_V(iv)%scsize(2) & + & *W_F(idf)%W_V(iv)%scsize(3) + ELSE + IF (l1d) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%datasz_in(1) + ELSE IF (l2d) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%datasz_in(1) & + & *W_F(idf)%W_V(iv)%datasz_in(2) + ELSE IF (l3d) THEN + W_F(idf)%W_V(iv)%datasz_max = & + & W_F(idf)%W_V(iv)%datasz_in(1) & + & *W_F(idf)%W_V(iv)%datasz_in(2) & + & *W_F(idf)%W_V(iv)%datasz_in(3) + ENDIF + ENDIF + ENDIF +!- + IF (.NOT.ALLOCATED(tbf_1)) THEN + IF (l_dbg) THEN + WRITE(*,*) & + & c_nam//" : allocate tbf_1 for size = ", & + & W_F(idf)%W_V(iv)%datasz_max + ENDIF + ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) + ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN + IF (l_dbg) THEN + WRITE(*,*) & + & c_nam//" : re-allocate tbf_1 for size = ", & + & W_F(idf)%W_V(iv)%datasz_max + ENDIF + DEALLOCATE(tbf_1) + ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max)) + ENDIF +!- +!-- We have to do the first operation anyway. +!-- Thus we do it here and change the ranke +!-- of the data at the same time. This should speed up things. +!- + nbpt_out = W_F(idf)%W_V(iv)%datasz_max + IF (l1d) THEN + nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1) + CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, & + & missing_val,nbindex,nindex, & + & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) + ELSE IF (l2d) THEN + nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2) + CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, & + & missing_val,nbindex,nindex, & + & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) + ELSE IF (l3d) THEN + nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3) + CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, & + & missing_val,nbindex,nindex, & + & W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1) + ENDIF + CALL histwrite_real (idf,iv,pitau,nbpt_out, & + & tbf_1,nbindex,nindex,do_oper,do_write) + ENDIF +!- +! 6.0 Manage time steps +!- + IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN + W_F(idf)%W_V(iv)%last_opp_chk = pitau + W_F(idf)%W_V(iv)%last_wrt_chk = pitau + ELSE + W_F(idf)%W_V(iv)%last_opp_chk = -99 + W_F(idf)%W_V(iv)%last_wrt_chk = -99 + ENDIF +!----------------------- +END SUBROUTINE histw_rnd +!=== +SUBROUTINE histwrite_real & + & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write) +!--------------------------------------------------------------------- +!- This subroutine is internal and does the calculations and writing +!- if needed. At a later stage it should be split into an operation +!- and writing subroutines. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: idf,pitau,iv, & + & nbindex,nindex(nbindex),nbdpt + REAL,DIMENSION(:) :: tbf_1 + LOGICAL,INTENT(IN) :: do_oper,do_write +!- + INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout + INTEGER :: nx,ny,nz,ky,kz,kt,kc + INTEGER,DIMENSION(4) :: corner,edges + INTEGER :: itime +!- + REAL :: rtime + REAL,DIMENSION(2) :: t_bnd + CHARACTER(LEN=7) :: tmp_opp + REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name + WRITE(*,*) "histwrite 0.0 : nbindex :",nbindex + WRITE(*,*) "histwrite 0.0 : nindex :",nindex(1:MIN(3,nbindex)),'...' + ENDIF +!- +! The sizes which can be encoutered +!- + tsz = W_F(idf)%W_V(iv)%zsize(1) & + & *W_F(idf)%W_V(iv)%zsize(2) & + & *W_F(idf)%W_V(iv)%zsize(3) +!- +! 1.0 We allocate and the temporary space needed for operations. +! The buffers are only deallocated when more space is needed. +! This reduces the umber of allocates but increases memory needs. +!- + IF (.NOT.ALLOCATED(tbf_2)) THEN + IF (l_dbg) THEN + WRITE(*,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1) + ENDIF + ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) + ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN + IF (l_dbg) THEN + WRITE(*,*) "histwrite_real 1.2 re-allocate tbf_2 : ", & + & SIZE(tbf_1)," instead of ",SIZE(tbf_2) + ENDIF + DEALLOCATE(tbf_2) + ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max)) + ENDIF +!- + rtime = pitau*W_F(idf)%deltat + tmp_opp = W_F(idf)%W_V(iv)%topp +!- +! 3.0 Do the operations or transfer the slab of data into tbf_1 +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 3.0",idf + ENDIF +!- +! 3.1 DO the Operations only if needed +!- + IF (do_oper) THEN + nbout = nbdpt +!- +!-- 3.4 We continue the sequence of operations +!-- we started in the interface routine +!- + DO io=2,W_F(idf)%W_V(iv)%nbopp,2 + nbin = nbout + nbout = W_F(idf)%W_V(iv)%datasz_max + CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, & + & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), & + & nbout,tbf_2) + IF (l_dbg) THEN + WRITE(*,*) & + & "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io) + ENDIF +!- + nbin = nbout + nbout = W_F(idf)%W_V(iv)%datasz_max + CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, & + & missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), & + & nbout,tbf_1) + IF (l_dbg) THEN + WRITE(*,*) & + & "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1) + ENDIF + ENDDO +!- +! 3.5 Zoom into the data +!- + IF (l_dbg) THEN + WRITE(*,*) & + & "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1) + WRITE(*,*) & + & "histwrite: 3.5 slab in X :", & + & W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1) + WRITE(*,*) & + & "histwrite: 3.5 slab in Y :", & + & W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2) + WRITE(*,*) & + & "histwrite: 3.5 slab in Z :", & + & W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3) + WRITE(*,*) & + & "histwrite: 3.5 slab of input:", & + & W_F(idf)%W_V(iv)%scsize(1), & + & W_F(idf)%W_V(iv)%scsize(2), & + & W_F(idf)%W_V(iv)%scsize(3) + ENDIF +!--- +!-- We have to consider blocks of contiguous data +!--- + nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1) + ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1) + nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1) + IF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & + & .AND.( W_F(idf)%W_V(iv)%zsize(1) & + & == W_F(idf)%W_V(iv)%scsize(1)) & + & .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) & + & .AND.( W_F(idf)%W_V(iv)%zsize(2) & + & == W_F(idf)%W_V(iv)%scsize(2))) THEN + kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny + tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz) + ELSEIF ( (W_F(idf)%W_V(iv)%zorig(1) == 1) & + & .AND.( W_F(idf)%W_V(iv)%zsize(1) & + & == W_F(idf)%W_V(iv)%scsize(1))) THEN + kc = -nx*ny + DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 + kc = kc+nx*ny + kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) & + & +W_F(idf)%W_V(iv)%zorig(2)-1)*nx + tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny) + ENDDO + ELSE + kc = -nx + DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1 + DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1 + kc = kc+nx + kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) & + & *W_F(idf)%W_V(iv)%scsize(1) & + & +W_F(idf)%W_V(iv)%zorig(1)-1 + tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx) + ENDDO + ENDDO + ENDIF +!- +!-- 4.0 Get the min and max of the field +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 4.0 tbf_1",idf,iv, & + & TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex + ENDIF +!- + IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN + W_F(idf)%W_V(iv)%hist_minmax(1) = & + & MIN(W_F(idf)%W_V(iv)%hist_minmax(1), & + & MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) + W_F(idf)%W_V(iv)%hist_minmax(2) = & + & MAX(W_F(idf)%W_V(iv)%hist_minmax(2), & + & MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val)) + ENDIF +!- +!-- 5.0 Do the operations if needed. In the case of instantaneous +!-- output we do not transfer to the time_buffer. +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz + ENDIF +!- + IF ( (TRIM(tmp_opp) /= "inst") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN + CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, & + & tbf_2,W_F(idf)%W_V(iv)%nb_opp) + ENDIF +!- + W_F(idf)%W_V(iv)%last_opp = pitau + W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1 +!- + ENDIF +!- +! 6.0 Write to file if needed +!- + IF (l_dbg) WRITE(*,*) "histwrite: 6.0",idf +!- + IF (do_write) THEN +!- + nfid = W_F(idf)%ncfid + nvid = W_F(idf)%W_V(iv)%ncvid +!- +!-- 6.1 Do the operations that are needed before writting +!- + IF (l_dbg) WRITE(*,*) "histwrite: 6.1",idf +!- + IF ( (TRIM(tmp_opp) /= "inst") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN + t_bnd(1:2) = (/ W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat,rtime /) + rtime = (t_bnd(1)+t_bnd(2))/2.0 + ENDIF +!- +!-- 6.2 Add a value to the time axis of this variable if needed +!- + IF ( (TRIM(tmp_opp) /= "l_max") & + & .AND.(TRIM(tmp_opp) /= "l_min") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN +!- + IF (l_dbg) WRITE(*,*) "histwrite: 6.2",idf +!- + itax = W_F(idf)%W_V(iv)%t_axid + itime = W_F(idf)%W_V(iv)%nb_wrt+1 +!- + IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN + iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, & + & (/ rtime /),start=(/ itime /),count=(/ 1 /)) + IF (W_F(idf)%W_V(itax)%tbndid > 0) THEN + iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tbndid, & + & t_bnd,start=(/ 1,itime /),count=(/ 2,1 /)) + ENDIF + W_F(idf)%W_V(itax)%tax_last = itime + ENDIF + ELSE + itime=1 + ENDIF +!- +!-- 6.3 Write the data. Only in the case of instantaneous output +! we do not write the buffer. +!- + IF (l_dbg) THEN + WRITE(*,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime + ENDIF +!- + IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN + IF (W_F(idf)%regular) THEN + corner(1:4) = (/ 1,1,itime,0 /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & + & W_F(idf)%W_V(iv)%zsize(2),1,0 /) + ELSE + corner(1:4) = (/ 1,itime,0,0 /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /) + ENDIF + ELSE + IF (W_F(idf)%regular) THEN + corner(1:4) = (/ 1,1,1,itime /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & + & W_F(idf)%W_V(iv)%zsize(2), & + & W_F(idf)%W_V(iv)%zsize(3),1 /) + ELSE + corner(1:4) = (/ 1,1,itime,0 /) + edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), & + & W_F(idf)%W_V(iv)%zsize(3),1,0 /) + ENDIF + ENDIF +!- + IF ( (TRIM(tmp_opp) /= "inst") & + & .AND.(TRIM(tmp_opp) /= "once") ) THEN + iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, & + & start=corner(1:4),count=edges(1:4)) + ELSE + iret = NF90_PUT_VAR (nfid,nvid,tbf_2, & + & start=corner(1:4),count=edges(1:4)) + ENDIF +!- + W_F(idf)%W_V(iv)%last_wrt = pitau + W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1 + W_F(idf)%W_V(iv)%nb_opp = 0 +!--- +! After the write the file can be synchronized so that no data is +! lost in case of a crash. This feature gives up on the benefits of +! buffering and should only be used in debuging mode. A flag is +! needed here to switch to this mode. +!--- +! iret = NF90_SYNC (nfid) +!- + ENDIF +!---------------------------- +END SUBROUTINE histwrite_real +!=== +SUBROUTINE histvar_seq (idf,pvarname,idv) +!--------------------------------------------------------------------- +!- This subroutine optimize the search for the variable in the table. +!- In a first phase it will learn the succession of the variables +!- called and then it will use the table to guess what comes next. +!- It is the best solution to avoid lengthy searches through array +!- vectors. +!- +!- ARGUMENTS : +!- +!- idf : id of the file on which we work +!- pvarname : The name of the variable we are looking for +!- idv : The var id we found +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in) :: idf + CHARACTER(LEN=*),INTENT(IN) :: pvarname + INTEGER,INTENT(out) :: idv +!- + LOGICAL,SAVE :: learning(nb_files_max)=.TRUE. + INTEGER,SAVE :: overlap(nb_files_max) = -1 + INTEGER,SAVE :: varseq(nb_files_max,nb_var_max*3) + INTEGER,SAVE :: varseq_len(nb_files_max) = 0 + INTEGER,SAVE :: varseq_pos(nb_files_max) + INTEGER,SAVE :: varseq_err(nb_files_max) = 0 + INTEGER :: ib,sp,nn,pos + CHARACTER(LEN=70) :: str70 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) 'histvar_seq, start of the subroutine :',learning(idf) + ENDIF +!- + IF (learning(idf)) THEN +!- +!-- 1.0 We compute the length over which we are going +!-- to check the overlap +!- + IF (overlap(idf) <= 0) THEN + IF (W_F(idf)%n_var > 6) THEN + overlap(idf) = W_F(idf)%n_var/3*2 + ELSE + overlap(idf) = W_F(idf)%n_var + ENDIF + ENDIF +!- +!-- 1.1 Find the position of this string +!- + CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) + IF (pos > 0) THEN + idv = pos + ELSE + CALL ipslerr (3,"histvar_seq", & + & 'The name of the variable you gave has not been declared', & + & 'You should use subroutine histdef for declaring variable', & + & TRIM(pvarname)) + ENDIF +!- +!-- 1.2 If we have not given up we store the position +!-- in the sequence of calls +!- + IF (varseq_err(idf) >= 0) THEN + sp = varseq_len(idf)+1 + IF (sp <= nb_var_max*3) THEN + varseq(idf,sp) = idv + varseq_len(idf) = sp + ELSE + CALL ipslerr (2,"histvar_seq",& + & 'The learning process has failed and we give up. '// & + & 'Either you sequence is',& + & 'too complex or I am too dumb. '// & + & 'This will only affect the efficiency',& + & 'of your code. Thus if you wish to save time'// & + & ' contact the IOIPSL team. ') + WRITE(*,*) 'The sequence we have found up to now :' + WRITE(*,*) varseq(idf,1:sp-1) + varseq_err(idf) = -1 + ENDIF +!- +!---- 1.3 Check if we have found the right overlap +!- + IF (varseq_len(idf) >= overlap(idf)*2) THEN +!- +!------ We skip a few variables if needed as they could come +!------ from the initialisation of the model. +!- + DO ib = 0,sp-overlap(idf)*2 + IF ( learning(idf) .AND.& + & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -& + & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN + learning(idf) = .FALSE. + varseq_len(idf) = sp-overlap(idf)-ib + varseq_pos(idf) = overlap(idf)+ib + varseq(idf,1:varseq_len(idf)) = & + & varseq(idf,ib+1:ib+varseq_len(idf)) + ENDIF + ENDDO + ENDIF + ENDIF + ELSE +!- +!-- 2.0 Now we know how the calls to histwrite are sequenced +!-- and we can get a guess at the var ID +!- + nn = varseq_pos(idf)+1 + IF (nn > varseq_len(idf)) nn = 1 +!- + idv = varseq(idf,nn) +!- + IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN + CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos) + IF (pos > 0) THEN + idv = pos + ELSE + CALL ipslerr (3,"histvar_seq", & + & 'The name of the variable you gave has not been declared',& + & 'You should use subroutine histdef for declaring variable', & + & TRIM(pvarname)) + ENDIF + varseq_err(idf) = varseq_err(idf)+1 + ELSE +!- +!---- We only keep the new position if we have found the variable +!---- this way. This way an out of sequence call to histwrite does +!---- not defeat the process. +!- + varseq_pos(idf) = nn + ENDIF +!- +!!$ IF (varseq_err(idf) >= 10) THEN +!!$ WRITE(str70,'("for file ",I3)') idf +!!$ CALL ipslerr (2,"histvar_seq", & +!!$ & 'There were 10 errors in the learned sequence of variables',& +!!$ & str70,'This looks like a bug, please report it.') +!!$ varseq_err(idf) = 0 +!!$ ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) & + & 'histvar_seq, end of the subroutine :',TRIM(pvarname),idv + ENDIF +!------------------------- +END SUBROUTINE histvar_seq +!=== +SUBROUTINE histsync (idf) +!--------------------------------------------------------------------- +!- This subroutine will synchronise all +!- (or one if defined) opened files. +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! idf : optional argument for fileid + INTEGER,INTENT(in),OPTIONAL :: idf +!- + INTEGER :: ifile,iret,i_s,i_e +!- + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->histsync" + ENDIF +!- + IF (PRESENT(idf)) THEN + IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN + IF (W_F(idf)%ncfid > 0) THEN + i_s = idf + i_e = idf + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'histsync', & + & 'Unable to synchronise the file :','probably','not opened') + ENDIF + ELSE + CALL ipslerr (3,'histsync','Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_files_max + ENDIF +!- + DO ifile=i_s,i_e + IF (W_F(ifile)%ncfid > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' histsync - synchronising file number ',ifile + ENDIF + iret = NF90_SYNC(W_F(ifile)%ncfid) + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-histsync" + ENDIF +!---------------------- +END SUBROUTINE histsync +!=== +SUBROUTINE histclo (idf) +!--------------------------------------------------------------------- +!- This subroutine will close all (or one if defined) opened files +!- +!- VERSION +!- +!--------------------------------------------------------------------- + IMPLICIT NONE +!- +! idf : optional argument for fileid + INTEGER,INTENT(in),OPTIONAL :: idf +!- + INTEGER :: ifile,nfid,nvid,iret,iv,i_s,i_e + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) THEN + WRITE(*,*) "->histclo" + ENDIF +!- + IF (PRESENT(idf)) THEN + IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN + IF (W_F(idf)%ncfid > 0) THEN + i_s = idf + i_e = idf + ELSE + i_s = 1 + i_e = 0 + CALL ipslerr (2,'histclo', & + & 'Unable to close the file :','probably','not opened') + ENDIF + ELSE + CALL ipslerr (3,'histclo','Invalid file identifier',' ',' ') + ENDIF + ELSE + i_s = 1 + i_e = nb_files_max + ENDIF +!- + DO ifile=i_s,i_e + IF (W_F(ifile)%ncfid > 0) THEN + IF (l_dbg) THEN + WRITE(*,*) ' histclo - closing specified file number :',ifile + ENDIF + nfid = W_F(ifile)%ncfid + iret = NF90_REDEF(nfid) +!----- +!---- 1. Loop on the number of variables to add some final information +!----- + IF (l_dbg) THEN + WRITE(*,*) ' Entering loop on vars : ',W_F(ifile)%n_var + ENDIF + DO iv=1,W_F(ifile)%n_var +!------ Extrema + IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN + IF (l_dbg) THEN + WRITE(*,*) 'min value for file :',ifile,' var n. :',iv, & + & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1) + WRITE(*,*) 'max value for file :',ifile,' var n. :',iv, & + & ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2) + ENDIF + IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN +!---------- Put the min and max values on the file + nvid = W_F(ifile)%W_V(iv)%ncvid + IF (W_F(ifile)%W_V(iv)%v_typ == hist_r8) THEN + iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=8)) + iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=8)) + ELSE + iret = NF90_PUT_ATT(nfid,nvid,'valid_min', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4)) + iret = NF90_PUT_ATT(nfid,nvid,'valid_max', & + & REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4)) + ENDIF + ENDIF + ENDIF +!------ Time-Buffers + IF (ASSOCIATED(W_F(ifile)%W_V(iv)%t_bf)) THEN + DEALLOCATE(W_F(ifile)%W_V(iv)%t_bf) + ENDIF +!------ Reinitialize the sizes + W_F(ifile)%W_V(iv)%datasz_in(:) = -1 + W_F(ifile)%W_V(iv)%datasz_max = -1 + ENDDO +!----- +!---- 2. Close the file +!----- + IF (l_dbg) WRITE(*,*) ' close file :',nfid + iret = NF90_CLOSE(nfid) + W_F(ifile)%ncfid = -1 + W_F(ifile)%dom_id_svg = -1 + ENDIF + ENDDO +!- + IF (l_dbg) THEN + WRITE(*,*) "<-histclo" + ENDIF +!--------------------- +END SUBROUTINE histclo +!=== +SUBROUTINE ioconf_modname (str) +!--------------------------------------------------------------------- +!- This subroutine allows to configure the name +!- of the model written into the file +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: str +!--------------------------------------------------------------------- + IF (.NOT.lock_modname) THEN + model_name = str(1:MIN(LEN_TRIM(str),80)) + lock_modname = .TRUE. + ELSE + CALL ipslerr (2,"ioconf_modname", & + & 'The model name can only be changed once and only', & + & 'before it is used. It is now set to :',model_name) + ENDIF +!---------------------------- +END SUBROUTINE ioconf_modname +!- +!=== +!- +!----------------- +END MODULE histcom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/ioipsl.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/ioipsl.f90 new file mode 100644 index 0000000..9907623 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/ioipsl.f90 @@ -0,0 +1,17 @@ +MODULE ioipsl +! +!$Id: ioipsl.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +! + USE errioipsl + USE stringop + USE mathelp + USE getincom + USE calendar + USE fliocom + USE flincom + USE histcom + USE restcom +END MODULE ioipsl diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/mathelp.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/mathelp.f90 new file mode 100644 index 0000000..99d046a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/mathelp.f90 @@ -0,0 +1,3122 @@ +MODULE mathelp +!- +!$Id: mathelp.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- + USE errioipsl,ONLY : ipslerr + USE stringop +!- + PRIVATE + PUBLIC :: mathop,moycum,buildop +!- + INTERFACE mathop + MODULE PROCEDURE mathop_r11,mathop_r21,mathop_r31 + END INTERFACE +!- +!- Variables used to detect and identify the operations +!- + CHARACTER(LEN=80),SAVE :: & + & seps='( ) , + - / * ^', ops = '+ - * / ^', mima = 'min max' + CHARACTER(LEN=250),SAVE :: & + & funcs = 'sin cos tan asin acos atan exp log sqrt chs abs '& + & //'cels kelv deg rad gather scatter fill coll undef only ident' + CHARACTER(LEN=120),SAVE :: & + & indexfu = 'gather, scatter, fill, coll, undef, only' +!--------------------------------------------------------------------- +CONTAINS +!=== +SUBROUTINE buildop (c_str,ex_topps,topp,fill_val,opps,scal,nbops) +!--------------------------------------------------------------------- +!- This subroutine decomposes the input string in the elementary +!- functions which need to be applied to the vector of data. +!- This vector is represented by X in the string. +!- This subroutine is the driver of the decomposition and gets +!- the time operation but then call decoop for the other operations +!- +!- INPUT +!- +!- c_str : String containing the operations +!- ex_toops : Time operations that can be expected within the string +!- fill_val : +!- +!- OUTPUT +!- +!- topp : Time operation +!- opps : +!- scal : +!- nbops : +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: c_str,ex_topps + CHARACTER(LEN=*),INTENT(OUT) :: topp + CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps + REAL,INTENT(IN) :: fill_val + REAL,DIMENSION(:),INTENT(OUT) :: scal + INTEGER,INTENT(OUT) :: nbops +!- + CHARACTER(LEN=LEN(c_str)) :: str,new_str + INTEGER :: leng,ind_opb,ind_clb +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning' +!- + str = c_str + leng = LEN_TRIM(str) + IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN + str = str(2:leng-1) + leng = leng-2 + ENDIF +!- + IF (check) & + & WRITE(*,*) 'buildop : Starting to test the various options' +!- + IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN + IF (check) WRITE(*,*) 'buildop : Time operation only' + nbops = 0 + topp = str(1:leng) + ELSE + IF (check) THEN + WRITE(*,*) 'buildop : Time operation and something else' + ENDIF +!-- + ind_opb = INDEX(str(1:leng),'(') + IF (ind_opb > 0) THEN + IF (INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN + IF (check) THEN + WRITE(*,'(2a)') & + & ' buildop : Extract time operation from : ',str + ENDIF + topp = str(1:ind_opb-1) + ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.) + new_str = str(ind_opb+1:ind_clb-1) + IF (check) THEN + WRITE(*,'(2a,2I3)') & + & ' buildop : Call decoop ',new_str,ind_opb,ind_clb + ENDIF + CALL decoop (new_str,fill_val,opps,scal,nbops) + ELSE + CALL ipslerr(3,'buildop', & + & 'time operation does not exist',str(1:ind_opb-1),' ') + ENDIF + ELSE + CALL ipslerr(3,'buildop', & + & 'some long operation exists but wihout parenthesis', & + & str(1:leng),' ') + ENDIF + ENDIF +!- + IF (check) THEN + DO leng=1,nbops + WRITE(*,*) & + & 'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng) + ENDDO + ENDIF +!--------------------- +END SUBROUTINE buildop +!=== +SUBROUTINE decoop (pstr,fill_val,opps,scal,nbops) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: pstr + REAL,INTENT(IN) :: fill_val + CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps + REAL,DIMENSION(:),INTENT(OUT) :: scal + INTEGER,INTENT(OUT) :: nbops +!- + CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char + INTEGER,DIMENSION(2) :: f_pos,s_pos + CHARACTER(LEN=20) :: opp_str,scal_str + CHARACTER(LEN=LEN(pstr)) :: str + INTEGER :: nbsep,nbops_max,xpos,leng,ppos,epos,int_tmp + CHARACTER(LEN=3) :: tl,dl + CHARACTER(LEN=10) :: fmt +!- + LOGICAL :: check = .FALSE.,prio +!--------------------------------------------------------------------- + IF (check) WRITE(*,'(2A)') ' decoop : Incoming string : ',pstr +!- + str = pstr; nbops = 0; +!- + CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos) + IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep +!- + nbops_max = min(SIZE(opps),SIZE(scal)) +!- + DO WHILE (nbsep > 0) + IF (nbops >= nbops_max) THEN + CALL ipslerr(3,'decoop','Expression too complex',TRIM(str),' ') + ENDIF +!-- + xpos = INDEX(str,'X') + leng = LEN_TRIM(str) + nbops = nbops+1 +!-- + IF (check) THEN + WRITE(*,*) 'decoop : str -> ',TRIM(str) + WRITE(*,*) 'decoop : nbops -> ',nbops + WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2) + WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2) + ENDIF +!--- +!-- Start the analysis of the syntax. 3 types of constructs +!-- are recognized. They are scanned sequentialy +!--- + IF (nbsep == 1) THEN + IF (check) WRITE(*,*) 'decoop : Only one operation' + IF (INDEX(ops,f_char(1)) > 0) THEN +!------ Type : scal+X + IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN + opp_str = f_char(1)//'I' + ELSE + opp_str = f_char(1) + ENDIF + scal_str = str(s_pos(1)+1:f_pos(1)-1) + str = 'X' + ELSE IF (INDEX(ops,f_char(2)) > 0) THEN +!------ Type : X+scal + opp_str = f_char(2) + scal_str = str(f_pos(2)+1:s_pos(2)-1) + str = 'X' + ELSE + CALL ipslerr(3,'decoop', & + & 'Unknown operations of type X+scal',f_char(1),pstr) + ENDIF + ELSE + IF (check) WRITE(*,*) 'decoop : More complex operation' + IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN +!------ Type : sin(X) + opp_str = str(s_pos(1)+1:f_pos(1)-1) + scal_str = '?' + str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng) + ELSE IF ( (f_char(1) == '(' .AND. f_char(2) == ',')& + & .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN +!------ Type : max(X,scal) or max(scal,X) + IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN +!-------- Type : max(X,scal) + opp_str = str(f_pos(1)-3:f_pos(1)-1) + scal_str = str(f_pos(2)+1:s_pos(2)-1) + str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng) + ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN +!-------- Type : max(scal,X) + opp_str = str(s_pos(1)-3:s_pos(1)-1) + scal_str = str(s_pos(1)+1:f_pos(1)-1) + str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng) + ELSE + CALL ipslerr(3,'decoop','Syntax error 1',str,' ') + ENDIF + ELSE + prio = (f_char(2) == '*').OR.(f_char(2) == '^') + IF ( (INDEX(ops,f_char(1)) > 0) & + & .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN +!-------- Type : ... scal+X ... + IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN + opp_str = f_char(1)//'I' + ELSE + opp_str = f_char(1) + ENDIF + scal_str = str(s_pos(1)+1:f_pos(1)-1) + str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng) + ELSE IF ( (INDEX(ops,f_char(2)) > 0) & + & .AND.(f_pos(2)-xpos == 1) ) THEN +!-------- Type : ... X+scal ... + opp_str = f_char(2) + scal_str = str(f_pos(2)+1:s_pos(2)-1) + str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng) + ELSE + CALL ipslerr(3,'decoop','Syntax error 2',str,' ') + ENDIF + ENDIF + ENDIF +!--- + IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',TRIM(str) +!--- +!-- Now that the different components of the operation are identified +!-- we transform them into what is going to be used in the program +!--- + IF (INDEX(scal_str,'?') > 0) THEN + IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN + opps(nbops) = opp_str(1:LEN_TRIM(opp_str)) + scal(nbops) = fill_val + ELSE + CALL ipslerr(3,'decoop', & + & 'Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ') + ENDIF + ELSE + leng = LEN_TRIM(opp_str) + IF (INDEX(mima,opp_str(1:leng)) > 0) THEN + opps(nbops) = 'fu'//opp_str(1:leng) + ELSE + IF (INDEX(opp_str(1:leng),'+') > 0) THEN + opps(nbops) = 'add' + ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN + opps(nbops) = 'subi' + ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN + opps(nbops) = 'sub' + ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN + opps(nbops) = 'mult' + ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN + opps(nbops) = 'div' + ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN + opps(nbops) = 'divi' + ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN + opps(nbops) = 'power' + ELSE + CALL ipslerr(3,'decoop', & + & 'Unknown operation',opp_str(1:leng),' ') + ENDIF + ENDIF +!----- + leng = LEN_TRIM(scal_str) + ppos = INDEX(scal_str,'.') + epos = INDEX(scal_str,'e') + IF (epos == 0) epos = INDEX(scal_str,'E') +!----- +!---- Try to catch a few errors +!----- + IF (INDEX(ops,scal_str) > 0) THEN + CALL ipslerr(3,'decoop', & + & 'Strange scalar you have here ',scal_str,pstr) + ENDIF + IF (epos > 0) THEN + WRITE(tl,'(I3.3)') leng + WRITE(dl,'(I3.3)') epos-ppos-1 + fmt='(e'//tl//'.'//dl//')' + READ(scal_str,fmt) scal(nbops) + ELSE IF (ppos > 0) THEN + WRITE(tl,'(I3.3)') leng + WRITE(dl,'(I3.3)') leng-ppos + fmt='(f'//tl//'.'//dl//')' + READ(scal_str,fmt) scal(nbops) + ELSE + WRITE(tl,'(I3.3)') leng + fmt = '(I'//tl//')' + READ(scal_str,fmt) int_tmp + scal(nbops) = REAL(int_tmp) + ENDIF + ENDIF + IF (check) WRITE(*,*) 'decoop : Finished interpretation' + CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos) + ENDDO +!-------------------- +END SUBROUTINE decoop +!=== +SUBROUTINE findsep (str,nbsep,f_char,f_pos,s_char,s_pos) +!--------------------------------------------------------------------- +!- Subroutine finds all separators in a given string +!- It returns the following information about str : +!- f_char : The first separation character +!- (1 for before and 2 for after) +!- f_pos : The position of the first separator +!- s_char : The second separation character +!- (1 for before and 2 for after) +!- s_pos : The position of the second separator +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(INOUT) :: str + INTEGER :: nbsep + CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char + INTEGER,DIMENSION(2) :: f_pos,s_pos +!- + CHARACTER(LEN=10) :: str_tmp + LOGICAL :: f_found,s_found + INTEGER :: ind,xpos,leng,i +!- + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + IF (check) WRITE(*,*) 'findsep : call cleanstr: ',TRIM(str) +!- + CALL cleanstr(str) +!- + IF (check) WRITE(*,*) 'findsep : out of cleanstr: ',TRIM(str) +!- + xpos = INDEX(str,'X') + leng = LEN_TRIM(str) +!- + f_pos(1:2) = (/ 0,leng+1 /) + f_char(1:2) = (/ '?','?' /) + s_pos(1:2) = (/ 0,leng+1 /) + s_char(1:2) = (/ '?','?' /) +!- + nbsep = 0 +!- + f_found = .FALSE. + s_found = .FALSE. + IF (xpos > 1) THEN + DO i=xpos-1,1,-1 + ind = INDEX(seps,str(i:i)) + IF (ind > 0) THEN + IF (.NOT.f_found) THEN + f_char(1) = str(i:i) + f_pos(1) = i + nbsep = nbsep+1 + f_found = .TRUE. + ELSE IF (.NOT.s_found) THEN + s_char(1) = str(i:i) + s_pos(1) = i + nbsep = nbsep+1 + s_found = .TRUE. + ENDIF + ENDIF + ENDDO + ENDIF +!- + f_found = .FALSE. + s_found = .FALSE. + IF (xpos < leng) THEN + DO i=xpos+1,leng + ind = INDEX(seps,str(i:i)) + IF (ind > 0) THEN + IF (.NOT.f_found) THEN + f_char(2) = str(i:i) + f_pos(2) = i + nbsep = nbsep+1 + f_found = .TRUE. + ELSE IF (.NOT.s_found) THEN + s_char(2) = str(i:i) + s_pos(2) = i + nbsep = nbsep+1 + s_found = .TRUE. + ENDIF + ENDIF + ENDDO + ENDIF +!- + IF (nbsep > 4) THEN + WRITE(str_tmp,'("number :",I3)') nbsep + CALL ipslerr(3,'findsep', & + & 'How can I find that many separators',str_tmp,TRIM(str)) + ENDIF +!- + IF (check) WRITE(*,*) 'Finished findsep : ',nbsep,leng +!--------------------- +END SUBROUTINE findsep +!=== +SUBROUTINE cleanstr(str) +!--------------------------------------------------------------------- +!- We clean up the string by taking out the extra () and puting +!- everything in lower case except for the X describing the variable +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(INOUT) :: str +!- + INTEGER :: ind,leng,ic,it + LOGICAL :: check = .FALSE. +!--------------------------------------------------------------------- + leng = LEN_TRIM(str) + CALL strlowercase(str) +!- + ind = INDEX(str,'x') + IF (check) THEN + WRITE (*,*) 'cleanstr 1.0 : ind = ',ind, & +& ' str = ',str(1:leng),'---' + ENDIF +!- +! If the character before the x is not a letter then we can assume +! that it is the variable and promote it to a capital letter +!- + DO WHILE (ind > 0) + ic = 0 + IF (ind > 1) ic = IACHAR(str(ind-1:ind-1)) + IF (ic < 97 .OR. ic > 122) THEN + str(ind:ind) = 'X' + ENDIF + it = INDEX(str(ind+1:leng),'x') + IF (it > 0) THEN + ind = ind+it + ELSE + ind = it + ENDIF + ENDDO +!- + IF (check) WRITE (*,*) 'cleanstr 2.0 : str = ',str(1:leng),'---' +!- + IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN + str = str(2:leng-1) + ENDIF +!- + IF (check) WRITE (*,*) 'cleanstr 3.0 : str = ',str(1:leng),'---' +!- + leng = LEN_TRIM(str) + ind = INDEX(str,'((X))') + IF (ind > 0) THEN + str=str(1:ind-1)//'(X)'//str(ind+5:leng)//' ' + ENDIF +!- + IF (check) WRITE (*,*) 'cleanstr 4.0 : str = ',str(1:leng),'---' +!- + leng = LEN_TRIM(str) + ind = INDEX(str,'(X)') + IF (ind > 0 .AND. ind+3 < leng) THEN + IF ( (INDEX(seps,str(ind-1:ind-1)) > 0) & + & .AND. (INDEX(seps,str(ind+3:ind+3)) > 0) ) THEN + str=str(1:ind-1)//'X'//str(ind+3:leng)//' ' + ENDIF + ENDIF +!- + IF (check) WRITE (*,*) 'cleanstr 5.0 : str = ',str(1:leng),'---' +!- + leng = LEN_TRIM(str) + ind = INDEX(str(1:leng),' ') + DO WHILE (ind > 0) + str=str(1:ind-1)//str(ind+1:leng)//' ' + leng = LEN_TRIM(str) + ind = INDEX(str(1:leng),' ') + ENDDO +!- + IF (check) WRITE (*,*) 'cleanstr 6.0 : str = ',str(1:leng),'---' +!---------------------- +END SUBROUTINE cleanstr +!=== +!=== +SUBROUTINE mathop_r11 & + & (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) +!--------------------------------------------------------------------- +!- This subroutines gives an interface to the various operation +!- which are allowed. The interface is general enough to allow its use +!- for other cases. +!- +!- INPUT +!- +!- fun : function to be applied to the vector of data +!- nb : Length of input vector +!- work_in : Input vector of data (REAL) +!- miss_val : The value of the missing data flag (it has to be a +!- maximum value, in f90 : huge( a real )) +!- nb_index : Length of index vector +!- nindex : Vector of indices +!- scal : A scalar value for vector/scalar operations +!- nb_max : maximum length of output vector +!- +!- OUTPUT +!- +!- nb_max : Actual length of output variable +!- work_out : Output vector after the operation was applied +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: fun + INTEGER :: nb,nb_max,nb_index + INTEGER :: nindex(nb_index) + REAL :: work_in(nb),scal,miss_val + REAL :: work_out(nb_max) +!- + INTEGER :: ierr +!- + INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS +!--------------------------------------------------------------------- + ierr = 0 +!- + IF (scal >= miss_val-1.) THEN + IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN + SELECT CASE (fun) + CASE('sin') + ierr = ma_sin_r11(nb,work_in,nb_max,work_out) + CASE('cos') + ierr = ma_cos_r11(nb,work_in,nb_max,work_out) + CASE('tan') + ierr = ma_tan_r11(nb,work_in,nb_max,work_out) + CASE('asin') + ierr = ma_asin_r11(nb,work_in,nb_max,work_out) + CASE('acos') + ierr = ma_acos_r11(nb,work_in,nb_max,work_out) + CASE('atan') + ierr = ma_atan_r11(nb,work_in,nb_max,work_out) + CASE('exp') + ierr = ma_exp_r11(nb,work_in,nb_max,work_out) + CASE('log') + ierr = ma_log_r11(nb,work_in,nb_max,work_out) + CASE('sqrt') + ierr = ma_sqrt_r11(nb,work_in,nb_max,work_out) + CASE('chs') + ierr = ma_chs_r11(nb,work_in,nb_max,work_out) + CASE('abs') + ierr = ma_abs_r11(nb,work_in,nb_max,work_out) + CASE('cels') + ierr = ma_cels_r11(nb,work_in,nb_max,work_out) + CASE('kelv') + ierr = ma_kelv_r11(nb,work_in,nb_max,work_out) + CASE('deg') + ierr = ma_deg_r11(nb,work_in,nb_max,work_out) + CASE('rad') + ierr = ma_rad_r11(nb,work_in,nb_max,work_out) + CASE('ident') + ierr = ma_ident_r11(nb,work_in,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and no indexing', & + & 'but still unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a simple function',fun,' ') + ENDIF + ELSE + SELECT CASE (fun) + CASE('gather') + ierr = ma_fugath_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('scatter') + IF (nb_index > nb) THEN + work_out(1:nb_max) = miss_val + ierr=1 + ELSE + ierr = ma_fuscat_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + ENDIF + CASE('coll') + ierr = ma_fucoll_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('fill') + ierr = ma_fufill_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('undef') + ierr = ma_fuundef_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE('only') + ierr = ma_fuonly_r11(nb,work_in,nb_index,nindex, & +& miss_val,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and indexing',& + & 'was requested but with unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop_r11", & + & 'Error while executing an indexing function',fun,' ') + ENDIF + ENDIF + ELSE + SELECT CASE (fun) + CASE('fumin') + ierr = ma_fumin_r11(nb,work_in,scal,nb_max,work_out) + CASE('fumax') + ierr = ma_fumax_r11(nb,work_in,scal,nb_max,work_out) + CASE('add') + ierr = ma_add_r11(nb,work_in,scal,nb_max,work_out) + CASE('subi') + ierr = ma_subi_r11(nb,work_in,scal,nb_max,work_out) + CASE('sub') + ierr = ma_sub_r11(nb,work_in,scal,nb_max,work_out) + CASE('mult') + ierr = ma_mult_r11(nb,work_in,scal,nb_max,work_out) + CASE('div') + ierr = ma_div_r11(nb,work_in,scal,nb_max,work_out) + CASE('divi') + ierr = ma_divi_r11(nb,work_in,scal,nb_max,work_out) + CASE('power') + ierr = ma_power_r11(nb,work_in,scal,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'Unknown operation with a scalar',fun,' ') + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a scalar function',fun,' ') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE mathop_r11 +!- +!=== FUNCTIONS (only one argument) +!- +INTEGER FUNCTION ma_sin_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = SIN(x(i)) + ENDDO +!- + nbo = nb + ma_sin_r11 = 0 +!---------------------- +END FUNCTION ma_sin_r11 +!=== +INTEGER FUNCTION ma_cos_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = COS(x(i)) + ENDDO +!- + nbo = nb + ma_cos_r11 = 0 +!---------------------- +END FUNCTION ma_cos_r11 +!=== +INTEGER FUNCTION ma_tan_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = TAN(x(i)) + ENDDO +!- + nbo = nb + ma_tan_r11 = 0 +!---------------------- +END FUNCTION ma_tan_r11 +!=== +INTEGER FUNCTION ma_asin_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ASIN(x(i)) + ENDDO +!- + nbo = nb + ma_asin_r11 = 0 +!----------------------- +END FUNCTION ma_asin_r11 +!=== +INTEGER FUNCTION ma_acos_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ACOS(x(i)) + ENDDO +!- + nbo = nb + ma_acos_r11 = 0 +!----------------------- +END FUNCTION ma_acos_r11 +!=== +INTEGER FUNCTION ma_atan_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ATAN(x(i)) + ENDDO +!- + nbo = nb + ma_atan_r11 = 0 +!----------------------- +END FUNCTION ma_atan_r11 +!=== +INTEGER FUNCTION ma_exp_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = EXP(x(i)) + ENDDO +!- + nbo = nb + ma_exp_r11 = 0 +!---------------------- +END FUNCTION ma_exp_r11 +!=== +INTEGER FUNCTION ma_log_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = log(x(i)) + ENDDO +!- + nbo = nb + ma_log_r11 = 0 +!---------------------- +END FUNCTION ma_log_r11 +!=== +INTEGER FUNCTION ma_sqrt_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = SQRT(x(i)) + ENDDO +!- + nbo = nb + ma_sqrt_r11 = 0 +!----------------------- +END FUNCTION ma_sqrt_r11 +!=== +INTEGER FUNCTION ma_abs_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = ABS(x(i)) + ENDDO +!- + nbo = nb + ma_abs_r11 = 0 +!---------------------- +END FUNCTION ma_abs_r11 +!=== +INTEGER FUNCTION ma_chs_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*(-1.) + ENDDO +!- + nbo = nb + ma_chs_r11 = 0 +!---------------------- +END FUNCTION ma_chs_r11 +!=== +INTEGER FUNCTION ma_cels_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)-273.15 + ENDDO +!- + nbo = nb + ma_cels_r11 = 0 +!----------------------- +END FUNCTION ma_cels_r11 +!=== +INTEGER FUNCTION ma_kelv_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)+273.15 + ENDDO +!- + nbo = nb + ma_kelv_r11 = 0 +!----------------------- +END FUNCTION ma_kelv_r11 +!=== +INTEGER FUNCTION ma_deg_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*57.29577951 + ENDDO +!- + nbo = nb + ma_deg_r11 = 0 +!----------------------- +END FUNCTION ma_deg_r11 +!=== +INTEGER FUNCTION ma_rad_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*0.01745329252 + ENDDO +!- + nbo = nb + ma_rad_r11 = 0 +!---------------------- +END FUNCTION ma_rad_r11 +!=== +INTEGER FUNCTION ma_ident_r11(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,i + REAL :: x(nb),y(nbo) +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i) + ENDDO +!- + nbo = nb + ma_ident_r11 = 0 +!------------------------ +END FUNCTION ma_ident_r11 +!- +!=== OPERATIONS (two argument) +!- +INTEGER FUNCTION ma_add_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)+s + ENDDO +!- + nbo = nb + ma_add_r11 = 0 +!----------------------- + END FUNCTION ma_add_r11 +!=== +INTEGER FUNCTION ma_sub_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)-s + ENDDO +!- + nbo = nb + ma_sub_r11 = 0 +!---------------------- +END FUNCTION ma_sub_r11 +!=== +INTEGER FUNCTION ma_subi_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = s-x(i) + ENDDO +!- + nbo = nb + ma_subi_r11 = 0 +!----------------------- +END FUNCTION ma_subi_r11 +!=== +INTEGER FUNCTION ma_mult_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)*s + ENDDO +!- + nbo = nb + ma_mult_r11 = 0 +!----------------------- +END FUNCTION ma_mult_r11 +!=== +INTEGER FUNCTION ma_div_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)/s + ENDDO +!- + nbo = nb + ma_div_r11 = 0 +!----------------------- + END FUNCTION ma_div_r11 +!=== +INTEGER FUNCTION ma_divi_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = s/x(i) + ENDDO +!- + nbo = nb + ma_divi_r11 = 0 +!----------------------- +END FUNCTION ma_divi_r11 +!=== +INTEGER FUNCTION ma_power_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = x(i)**s + ENDDO +!- + nbo = nb + ma_power_r11 = 0 +!----------------------- +END FUNCTION ma_power_r11 +!=== +INTEGER FUNCTION ma_fumin_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = MIN(x(i),s) + ENDDO +!- + nbo = nb + ma_fumin_r11 = 0 +!------------------------ +END FUNCTION ma_fumin_r11 +!=== +INTEGER FUNCTION ma_fumax_r11(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo + REAL :: x(nb),s,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,nb + y(i) = MAX(x(i),s) + ENDDO +!- + nbo = nb + ma_fumax_r11 = 0 +!------------------------ +END FUNCTION ma_fumax_r11 +!=== +INTEGER FUNCTION ma_fuscat_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ii,ipos +!--------------------------------------------------------------------- + ma_fuscat_r11 = 0 +!- + y(1:nbo) = miss_val +!- + IF (nbi <= nb) THEN + ipos = 0 + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + ipos = ipos+1 + y(ind(i)) = x(ipos) + ELSE + IF (ind(i) > nbo) ma_fuscat_r11 = ma_fuscat_r11+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fuscat_r11 = ma_fuscat_r11+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fuscat_r11 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuscat_r11 +!=== +INTEGER FUNCTION ma_fugath_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fugath_r11 = 0 + y(1:nbo) = miss_val + ipos = 0 + DO i=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(i) > 0) THEN + ipos = ipos+1 + y(ipos) = x(ind(i)) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fugath_r11 = ma_fugath_r11+1 + ENDIF + ENDDO + ELSE + ma_fugath_r11 = 1 + ENDIF +!- + nbo = ipos +!------------------------- +END FUNCTION ma_fugath_r11 +!=== +INTEGER FUNCTION ma_fufill_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ii,ipos +!--------------------------------------------------------------------- + ma_fufill_r11 = 0 +!- + IF (nbi <= nb) THEN + ipos = 0 + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + ipos = ipos+1 + y(ind(i)) = x(ipos) + ELSE + IF (ind(i) > nbo) ma_fufill_r11 = ma_fufill_r11+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fufill_r11 = ma_fufill_r11+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fufill_r11 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fufill_r11 +!=== +INTEGER FUNCTION ma_fucoll_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fucoll_r11 = 0 + ipos = 0 + DO i=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(i) > 0) THEN + ipos = ipos+1 + y(ipos) = x(ind(i)) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fucoll_r11 = ma_fucoll_r11+1 + ENDIF + ENDDO + ELSE + ma_fucoll_r11 = 1 + ENDIF +!- + nbo = ipos +!------------------------- +END FUNCTION ma_fucoll_r11 +!=== +INTEGER FUNCTION ma_fuundef_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + IF (nbi <= nbo .AND. nbo == nb) THEN + ma_fuundef_r11 = 0 + DO i=1,nbo + y(i) = x(i) + ENDDO + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + y(ind(i)) = miss_val + ELSE + IF (ind(i) > nbo) ma_fuundef_r11 = ma_fuundef_r11+1 + ENDIF + ENDDO + ELSE + ma_fuundef_r11 = 1 + ENDIF +!-------------------------- +END FUNCTION ma_fuundef_r11 +!=== +INTEGER FUNCTION ma_fuonly_r11(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb,nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb),miss_val,y(nbo) +!- + INTEGER :: i +!--------------------------------------------------------------------- + IF ( (nbi <= nbo).AND.(nbo == nb) & + & .AND.ALL(ind(1:nbi) <= nbo) ) THEN + ma_fuonly_r11 = 0 + y(1:nbo) = miss_val + DO i=1,nbi + IF (ind(i) > 0) THEN + y(ind(i)) = x(ind(i)) + ENDIF + ENDDO + ELSE + ma_fuonly_r11 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuonly_r11 +!=== +!=== +SUBROUTINE mathop_r21 & + & (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) +!--------------------------------------------------------------------- +!- This subroutines gives an interface to the various operations +!- which are allowed. The interface is general enough to allow its use +!- for other cases. +!- +!- INPUT +!- +!- fun : function to be applied to the vector of data +!- nb : Length of input vector +!- work_in : Input vector of data (REAL) +!- miss_val : The value of the missing data flag (it has to be a +!- maximum value, in f90 : huge( a real )) +!- nb_index : Length of index vector +!- nindex : Vector of indices +!- scal : A scalar value for vector/scalar operations +!- nb_max : maximum length of output vector +!- +!- OUTPUT +!- +!- nb_max : Actual length of output variable +!- work_out : Output vector after the operation was applied +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: fun + INTEGER :: nb(2),nb_max,nb_index + INTEGER :: nindex(nb_index) + REAL :: work_in(nb(1),nb(2)),scal,miss_val + REAL :: work_out(nb_max) +!- + INTEGER :: ierr +!- + INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS +!--------------------------------------------------------------------- + ierr = 0 +!- + IF (scal >= miss_val-1.) THEN + IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN + SELECT CASE (fun) + CASE('sin') + ierr = ma_sin_r21(nb,work_in,nb_max,work_out) + CASE('cos') + ierr = ma_cos_r21(nb,work_in,nb_max,work_out) + CASE('tan') + ierr = ma_tan_r21(nb,work_in,nb_max,work_out) + CASE('asin') + ierr = ma_asin_r21(nb,work_in,nb_max,work_out) + CASE('acos') + ierr = ma_acos_r21(nb,work_in,nb_max,work_out) + CASE('atan') + ierr = ma_atan_r21(nb,work_in,nb_max,work_out) + CASE('exp') + ierr = ma_exp_r21(nb,work_in,nb_max,work_out) + CASE('log') + ierr = ma_log_r21(nb,work_in,nb_max,work_out) + CASE('sqrt') + ierr = ma_sqrt_r21(nb,work_in,nb_max,work_out) + CASE('chs') + ierr = ma_chs_r21(nb,work_in,nb_max,work_out) + CASE('abs') + ierr = ma_abs_r21(nb,work_in,nb_max,work_out) + CASE('cels') + ierr = ma_cels_r21(nb,work_in,nb_max,work_out) + CASE('kelv') + ierr = ma_kelv_r21(nb,work_in,nb_max,work_out) + CASE('deg') + ierr = ma_deg_r21(nb,work_in,nb_max,work_out) + CASE('rad') + ierr = ma_rad_r21(nb,work_in,nb_max,work_out) + CASE('ident') + ierr = ma_ident_r21(nb,work_in,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and no indexing', & + & 'but still unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a simple function',fun,' ') + ENDIF + ELSE + SELECT CASE (fun) + CASE('gather') + ierr = ma_fugath_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('scatter') + IF (nb_index > (nb(1)*nb(2)) ) THEN + work_out(1:nb_max) = miss_val + ierr=1 + ELSE + ierr = ma_fuscat_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + ENDIF + CASE('coll') + ierr = ma_fucoll_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('fill') + ierr = ma_fufill_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('undef') + ierr = ma_fuundef_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('only') + ierr = ma_fuonly_r21(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and indexing', & + & 'was requested but with unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop_r21", & + & 'Error while executing an indexing function',fun,' ') + ENDIF + ENDIF + ELSE + SELECT CASE (fun) + CASE('fumin') + ierr = ma_fumin_r21(nb,work_in,scal,nb_max,work_out) + CASE('fumax') + ierr = ma_fumax_r21(nb,work_in,scal,nb_max,work_out) + CASE('add') + ierr = ma_add_r21(nb,work_in,scal,nb_max,work_out) + CASE('subi') + ierr = ma_subi_r21(nb,work_in,scal,nb_max,work_out) + CASE('sub') + ierr = ma_sub_r21(nb,work_in,scal,nb_max,work_out) + CASE('mult') + ierr = ma_mult_r21(nb,work_in,scal,nb_max,work_out) + CASE('div') + ierr = ma_div_r21(nb,work_in,scal,nb_max,work_out) + CASE('divi') + ierr = ma_divi_r21(nb,work_in,scal,nb_max,work_out) + CASE('power') + ierr = ma_power_r21(nb,work_in,scal,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'Unknown operation with a scalar',fun,' ') + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a scalar function',fun,' ') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE mathop_r21 +!- +!=== FUNCTIONS (only one argument) +!- +INTEGER FUNCTION ma_sin_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SIN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_sin_r21 = 0 +!---------------------- +END FUNCTION ma_sin_r21 +!=== +INTEGER FUNCTION ma_cos_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = COS(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_cos_r21 = 0 +!---------------------- +END FUNCTION ma_cos_r21 +!=== +INTEGER FUNCTION ma_tan_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = TAN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_tan_r21 = 0 +!---------------------- +END FUNCTION ma_tan_r21 +!=== + INTEGER FUNCTION ma_asin_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ASIN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_asin_r21 = 0 +!----------------------- +END FUNCTION ma_asin_r21 +!=== +INTEGER FUNCTION ma_acos_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ACOS(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_acos_r21 = 0 +!----------------------- +END FUNCTION ma_acos_r21 +!=== +INTEGER FUNCTION ma_atan_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ATAN(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_atan_r21 = 0 +!----------------------- +END FUNCTION ma_atan_r21 +!=== +INTEGER FUNCTION ma_exp_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = EXP(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_exp_r21 = 0 +!---------------------- +END FUNCTION ma_exp_r21 +!=== +INTEGER FUNCTION ma_log_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = LOG(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_log_r21 = 0 +!---------------------- +END FUNCTION ma_log_r21 +!=== +INTEGER FUNCTION ma_sqrt_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SQRT(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_sqrt_r21 = 0 +!----------------------- +END FUNCTION ma_sqrt_r21 +!=== +INTEGER FUNCTION ma_abs_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ABS(x(i,j)) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_abs_r21 = 0 +!---------------------- +END FUNCTION ma_abs_r21 +!=== +INTEGER FUNCTION ma_chs_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*(-1.) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_chs_r21 = 0 +!---------------------- +END FUNCTION ma_chs_r21 +!=== +INTEGER FUNCTION ma_cels_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)-273.15 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_cels_r21 = 0 +!----------------------- +END FUNCTION ma_cels_r21 +!=== +INTEGER FUNCTION ma_kelv_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)+273.15 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_kelv_r21 = 0 +!----------------------- +END FUNCTION ma_kelv_r21 +!=== +INTEGER FUNCTION ma_deg_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*57.29577951 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_deg_r21 = 0 +!---------------------- +END FUNCTION ma_deg_r21 +!=== +INTEGER FUNCTION ma_rad_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*0.01745329252 + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_rad_r21 = 0 +!---------------------- +END FUNCTION ma_rad_r21 +!=== +INTEGER FUNCTION ma_ident_r21(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,i,j,ij + REAL :: x(nb(1),nb(2)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_ident_r21 = 0 +!------------------------ +END FUNCTION ma_ident_r21 +!- +!=== OPERATIONS (two argument) +!- +INTEGER FUNCTION ma_add_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)+s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_add_r21 = 0 +!---------------------- +END FUNCTION ma_add_r21 +!=== +INTEGER FUNCTION ma_sub_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)-s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_sub_r21 = 0 +!---------------------- +END FUNCTION ma_sub_r21 +!=== +INTEGER FUNCTION ma_subi_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s-x(i,j) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_subi_r21 = 0 +!----------------------- +END FUNCTION ma_subi_r21 +!=== +INTEGER FUNCTION ma_mult_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)*s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_mult_r21 = 0 +!----------------------- +END FUNCTION ma_mult_r21 +!=== +INTEGER FUNCTION ma_div_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j)/s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_div_r21 = 0 +!---------------------- +END FUNCTION ma_div_r21 +!=== +INTEGER FUNCTION ma_divi_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s/x(i,j) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_divi_r21 = 0 +!----------------------- +END FUNCTION ma_divi_r21 +!=== +INTEGER FUNCTION ma_power_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j) ** s + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_power_r21 = 0 +!------------------------ +END FUNCTION ma_power_r21 +!=== +INTEGER FUNCTION ma_fumin_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MIN(x(i,j),s) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_fumin_r21 = 0 +!------------------------ +END FUNCTION ma_fumin_r21 +!=== +INTEGER FUNCTION ma_fumax_r21(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo + REAL :: x(nb(1),nb(2)),s,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + ij = 0 + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MAX(x(i,j),s) + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2) + ma_fumax_r21 = 0 +!------------------------ +END FUNCTION ma_fumax_r21 +!=== +INTEGER FUNCTION ma_fuscat_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ii,ipos +!--------------------------------------------------------------------- + ma_fuscat_r21 = 0 +!- + y(1:nbo) = miss_val +!- + IF (nbi <= nb(1)*nb(2)) THEN + ipos = 0 + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + j = ((ipos-1)/nb(1))+1 + i = (ipos-(j-1)*nb(1)) + y(ind(ij)) = x(i,j) + ELSE + IF (ind(ij) > nbo) ma_fuscat_r21 = ma_fuscat_r21+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fuscat_r21 = ma_fuscat_r21+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fuscat_r21 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuscat_r21 +!=== +INTEGER FUNCTION ma_fugath_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fugath_r21 = 0 + y(1:nbo) = miss_val + ipos = 0 + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + j = ((ind(ij)-1)/nb(1))+1 + i = (ind(ij)-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fugath_r21 = ma_fugath_r21+1 + ENDIF + ENDDO + ELSE + ma_fugath_r21 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fugath_r21 +!=== +INTEGER FUNCTION ma_fufill_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ii,ipos +!--------------------------------------------------------------------- + ma_fufill_r21 = 0 +!- + IF (nbi <= nb(1)*nb(2)) THEN + ipos = 0 + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + j = ((ipos-1)/nb(1))+1 + i = (ipos-(j-1)*nb(1)) + y(ind(ij)) = x(i,j) + ELSE + IF (ind(ij) > nbo) ma_fufill_r21 = ma_fufill_r21+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fufill_r21 = ma_fufill_r21+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fufill_r21 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fufill_r21 +!=== +INTEGER FUNCTION ma_fucoll_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij,ipos +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fucoll_r21 = 0 + ipos = 0 + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + j = ((ind(ij)-1)/nb(1))+1 + i = (ind(ij)-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fucoll_r21 = ma_fucoll_r21+1 + ENDIF + ENDDO + ELSE + ma_fucoll_r21 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fucoll_r21 +!=== +INTEGER FUNCTION ma_fuundef_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + IF (nbi <= nbo .AND. nbo == nb(1)*nb(2)) THEN + ma_fuundef_r21 = 0 + DO ij=1,nbo + j = ((ij-1)/nb(1))+1 + i = (ij-(j-1)*nb(1)) + y(ij) = x(i,j) + ENDDO + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + y(ind(i)) = miss_val + ELSE + IF (ind(i) > nbo) ma_fuundef_r21 = ma_fuundef_r21+1 + ENDIF + ENDDO + ELSE + ma_fuundef_r21 = 1 + ENDIF +!-------------------------- +END FUNCTION ma_fuundef_r21 +!=== +INTEGER FUNCTION ma_fuonly_r21(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(2),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2)),miss_val,y(nbo) +!- + INTEGER :: i,j,ij +!--------------------------------------------------------------------- + IF ( (nbi <= nbo).AND.(nbo == nb(1)*nb(2)) & + & .AND.ALL(ind(1:nbi) <= nbo) ) THEN + ma_fuonly_r21 = 0 + y(1:nbo) = miss_val + DO ij=1,nbi + IF (ind(ij) > 0) THEN + j = ((ind(ij)-1)/nb(1))+1 + i = (ind(ij)-(j-1)*nb(1)) + y(ind(ij)) = x(i,j) + ENDIF + ENDDO + ELSE + ma_fuonly_r21 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuonly_r21 +!=== +!=== +SUBROUTINE mathop_r31 & + & (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out) +!--------------------------------------------------------------------- +!- This subroutines gives an interface to the various operations +!- which are allowed. The interface is general enough to allow its use +!- for other cases. +!- +!- INPUT +!- +!- fun : function to be applied to the vector of data +!- nb : Length of input vector +!- work_in : Input vector of data (REAL) +!- miss_val : The value of the missing data flag (it has to be a +!- maximum value, in f90 : huge( a real )) +!- nb_index : Length of index vector +!- nindex : Vector of indices +!- scal : A scalar value for vector/scalar operations +!- nb_max : maximum length of output vector +!- +!- OUTPUT +!- +!- nb_max : Actual length of output variable +!- work_out : Output vector after the operation was applied +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: fun + INTEGER :: nb(3),nb_max,nb_index + INTEGER :: nindex(nb_index) + REAL :: work_in(nb(1),nb(2),nb(3)),scal,miss_val + REAL :: work_out(nb_max) +!- + INTEGER :: ierr +!- + INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS +!--------------------------------------------------------------------- + ierr = 0 +!- + IF (scal >= miss_val-1.) THEN + IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN + SELECT CASE (fun) + CASE('sin') + ierr = ma_sin_r31(nb,work_in,nb_max,work_out) + CASE('cos') + ierr = ma_cos_r31(nb,work_in,nb_max,work_out) + CASE('tan') + ierr = ma_tan_r31(nb,work_in,nb_max,work_out) + CASE('asin') + ierr = ma_asin_r31(nb,work_in,nb_max,work_out) + CASE('acos') + ierr = ma_acos_r31(nb,work_in,nb_max,work_out) + CASE('atan') + ierr = ma_atan_r31(nb,work_in,nb_max,work_out) + CASE('exp') + ierr = ma_exp_r31(nb,work_in,nb_max,work_out) + CASE('log') + ierr = ma_log_r31(nb,work_in,nb_max,work_out) + CASE('sqrt') + ierr = ma_sqrt_r31(nb,work_in,nb_max,work_out) + CASE('chs') + ierr = ma_chs_r31(nb,work_in,nb_max,work_out) + CASE('abs') + ierr = ma_abs_r31(nb,work_in,nb_max,work_out) + CASE('cels') + ierr = ma_cels_r31(nb,work_in,nb_max,work_out) + CASE('kelv') + ierr = ma_kelv_r31(nb,work_in,nb_max,work_out) + CASE('deg') + ierr = ma_deg_r31(nb,work_in,nb_max,work_out) + CASE('rad') + ierr = ma_rad_r31(nb,work_in,nb_max,work_out) + CASE('ident') + ierr = ma_ident_r31(nb,work_in,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and no indexing', & + & 'but still unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a simple function',fun,' ') + ENDIF + ELSE + SELECT CASE (fun) + CASE('gather') + ierr = ma_fugath_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('scatter') + IF (nb_index > (nb(1)*nb(2)*nb(3))) THEN + work_out(1:nb_max) = miss_val + ierr=1 + ELSE + ierr = ma_fuscat_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + ENDIF + CASE('coll') + ierr = ma_fucoll_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('fill') + ierr = ma_fufill_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('undef') + ierr = ma_fuundef_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE('only') + ierr = ma_fuonly_r31(nb,work_in,nb_index,nindex, & + & miss_val,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'scalar variable undefined and indexing', & + & 'was requested but with unknown function',fun) + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop_r31", & + & 'Error while executing an indexing function',fun,' ') + ENDIF + ENDIF + ELSE + SELECT CASE (fun) + CASE('fumin') + ierr = ma_fumin_r31(nb,work_in,scal,nb_max,work_out) + CASE('fumax') + ierr = ma_fumax_r31(nb,work_in,scal,nb_max,work_out) + CASE('add') + ierr = ma_add_r31(nb,work_in,scal,nb_max,work_out) + CASE('subi') + ierr = ma_subi_r31(nb,work_in,scal,nb_max,work_out) + CASE('sub') + ierr = ma_sub_r31(nb,work_in,scal,nb_max,work_out) + CASE('mult') + ierr = ma_mult_r31(nb,work_in,scal,nb_max,work_out) + CASE('div') + ierr = ma_div_r31(nb,work_in,scal,nb_max,work_out) + CASE('divi') + ierr = ma_divi_r31(nb,work_in,scal,nb_max,work_out) + CASE('power') + ierr = ma_power_r31(nb,work_in,scal,nb_max,work_out) + CASE DEFAULT + CALL ipslerr(3,"mathop", & + & 'Unknown operation with a scalar',fun,' ') + END SELECT + IF (ierr > 0) THEN + CALL ipslerr(3,"mathop", & + & 'Error while executing a scalar function',fun,' ') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE mathop_r31 +!- +!=== FUNCTIONS (only one argument) +!- +INTEGER FUNCTION ma_sin_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SIN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_sin_r31 = 0 +!---------------------- +END FUNCTION ma_sin_r31 +!=== +INTEGER FUNCTION ma_cos_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = COS(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_cos_r31 = 0 +!---------------------- +END FUNCTION ma_cos_r31 +!=== +INTEGER FUNCTION ma_tan_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = TAN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_tan_r31 = 0 +!---------------------- +END FUNCTION ma_tan_r31 +!=== +INTEGER FUNCTION ma_asin_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ASIN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_asin_r31 = 0 +!----------------------- +END FUNCTION ma_asin_r31 +!=== +INTEGER FUNCTION ma_acos_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ACOS(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_acos_r31 = 0 +!----------------------- +END FUNCTION ma_acos_r31 +!=== +INTEGER FUNCTION ma_atan_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ATAN(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_atan_r31 = 0 +!----------------------- + END FUNCTION ma_atan_r31 +!=== +INTEGER FUNCTION ma_exp_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = EXP(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_exp_r31 = 0 +!---------------------- +END FUNCTION ma_exp_r31 +!=== +INTEGER FUNCTION ma_log_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = LOG(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_log_r31 = 0 +!---------------------- +END FUNCTION ma_log_r31 +!=== +INTEGER FUNCTION ma_sqrt_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = SQRT(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_sqrt_r31 = 0 +!----------------------- +END FUNCTION ma_sqrt_r31 +!=== +INTEGER FUNCTION ma_abs_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = ABS(x(i,j,k)) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_abs_r31 = 0 +!---------------------- +END FUNCTION ma_abs_r31 +!=== +INTEGER FUNCTION ma_chs_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*(-1.) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_chs_r31 = 0 +!---------------------- +END FUNCTION ma_chs_r31 +!=== +INTEGER FUNCTION ma_cels_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)-273.15 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_cels_r31 = 0 +!----------------------- +END FUNCTION ma_cels_r31 +!=== +INTEGER FUNCTION ma_kelv_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)+273.15 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_kelv_r31 = 0 +!----------------------- + END FUNCTION ma_kelv_r31 +!=== +INTEGER FUNCTION ma_deg_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*57.29577951 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_deg_r31 = 0 +!---------------------- +END FUNCTION ma_deg_r31 +!=== +INTEGER FUNCTION ma_rad_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*0.01745329252 + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_rad_r31 = 0 +!---------------------- +END FUNCTION ma_rad_r31 +!=== +INTEGER FUNCTION ma_ident_r31(nb,x,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,i,j,k,ij + REAL :: x(nb(1),nb(2),nb(3)),y(nbo) +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_ident_r31 = 0 +!------------------------ +END FUNCTION ma_ident_r31 +!- +!=== OPERATIONS (two argument) +!- +INTEGER FUNCTION ma_add_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)+s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_add_r31 = 0 +!---------------------- +END FUNCTION ma_add_r31 +!=== +INTEGER FUNCTION ma_sub_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)-s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_sub_r31 = 0 +!---------------------- +END FUNCTION ma_sub_r31 +!=== +INTEGER FUNCTION ma_subi_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s-x(i,j,k) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_subi_r31 = 0 +!----------------------- +END FUNCTION ma_subi_r31 +!=== +INTEGER FUNCTION ma_mult_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)*s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_mult_r31 = 0 +!----------------------- +END FUNCTION ma_mult_r31 +!=== +INTEGER FUNCTION ma_div_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)/s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_div_r31 = 0 +!---------------------- +END FUNCTION ma_div_r31 +!=== +INTEGER FUNCTION ma_divi_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = s/x(i,j,k) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_divi_r31 = 0 +!----------------------- +END FUNCTION ma_divi_r31 +!=== +INTEGER FUNCTION ma_power_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = x(i,j,k)**s + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_power_r31 = 0 +!------------------------ +END FUNCTION ma_power_r31 +!=== +INTEGER FUNCTION ma_fumin_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MIN(x(i,j,k),s) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_fumin_r31 = 0 +!------------------------ +END FUNCTION ma_fumin_r31 +!=== +INTEGER FUNCTION ma_fumax_r31(nb,x,s,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo + REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo) +!- + INTEGER :: i,j,k,ij +!--------------------------------------------------------------------- + ij = 0 + DO k=1,nb(3) + DO j=1,nb(2) + DO i=1,nb(1) + ij = ij+1 + y(ij) = MAX(x(i,j,k),s) + ENDDO + ENDDO + ENDDO +!- + nbo = nb(1)*nb(2)*nb(3) + ma_fumax_r31 = 0 +!------------------------ +END FUNCTION ma_fumax_r31 +!=== +INTEGER FUNCTION ma_fuscat_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ii,ipos,ipp,isb +!--------------------------------------------------------------------- + ma_fuscat_r31 = 0 +!- + y(1:nbo) = miss_val +!- + IF (nbi <= nb(1)*nb(2)*nb(3)) THEN + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + k = ((ipos-1)/isb)+1 + ipp = ipos-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ind(ij)) = x(i,j,k) + ELSE + IF (ind(ij) > nbo) ma_fuscat_r31 = ma_fuscat_r31+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fuscat_r31 = ma_fuscat_r31+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fuscat_r31 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuscat_r31 +!=== +INTEGER FUNCTION ma_fugath_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipos,ipp,isb +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fugath_r31 = 0 + y(1:nbo) = miss_val + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + k = ((ind(ij)-1)/isb)+1 + ipp = ind(ij)-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j,k) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fugath_r31 = ma_fugath_r31+1 + ENDIF + ENDDO + ELSE + ma_fugath_r31 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fugath_r31 +!=== +INTEGER FUNCTION ma_fufill_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ii,ipos,ipp,isb +!--------------------------------------------------------------------- + ma_fufill_r31 = 0 + IF (nbi <= nb(1)*nb(2)*nb(3)) THEN + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN + ipos = ipos+1 + k = ((ipos-1)/isb)+1 + ipp = ipos-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ind(ij)) = x(i,j,k) + ELSE + IF (ind(ij) > nbo) ma_fufill_r31 = ma_fufill_r31+1 + ENDIF + ENDDO +!-- Repeat the data if needed + IF (MINVAL(ind) < 0) THEN + DO i=1,nbi + IF (ind(i) <= 0) THEN + DO ii=1,ABS(ind(i))-1 + IF (ind(i+1)+ii <= nbo) THEN + y(ind(i+1)+ii) = y(ind(i+1)) + ELSE + ma_fufill_r31 = ma_fufill_r31+1 + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ELSE + ma_fufill_r31 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fufill_r31 +!=== +INTEGER FUNCTION ma_fucoll_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipos,ipp,isb +!--------------------------------------------------------------------- + IF (nbi <= nbo) THEN + ma_fucoll_r31 = 0 + ipos = 0 + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ipos+1 <= nbo) THEN + IF (ind(ij) > 0) THEN + k = ((ind(ij)-1)/isb)+1 + ipp = ind(ij)-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + ipos = ipos+1 + y(ipos) = x(i,j,k) + ENDIF + ELSE + IF (ipos+1 > nbo) ma_fucoll_r31 = ma_fucoll_r31+1 + ENDIF + ENDDO + ELSE + ma_fucoll_r31 = 1 + ENDIF + nbo = ipos +!------------------------- +END FUNCTION ma_fucoll_r31 +!=== +INTEGER FUNCTION ma_fuundef_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipp,isb +!--------------------------------------------------------------------- + IF (nbi <= nbo .AND. nbo == nb(1)*nb(2)*nb(3)) THEN + ma_fuundef_r31 = 0 + isb = nb(1)*nb(2) + DO ij=1,nbo + k = ((ij-1)/isb)+1 + ipp = ij-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ij) = x(i,j,k) + ENDDO + DO i=1,nbi + IF (ind(i) <= nbo .AND. ind(i) > 0) THEN + y(ind(i)) = miss_val + ELSE + IF (ind(i) > nbo) ma_fuundef_r31 = ma_fuundef_r31+1 + ENDIF + ENDDO + ELSE + ma_fuundef_r31 = 1 + ENDIF +!-------------------------- +END FUNCTION ma_fuundef_r31 +!=== +INTEGER FUNCTION ma_fuonly_r31(nb,x,nbi,ind,miss_val,nbo,y) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: nb(3),nbo,nbi + INTEGER :: ind(nbi) + REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo) +!- + INTEGER :: i,j,k,ij,ipp,isb +!--------------------------------------------------------------------- + IF ( (nbi <= nbo).AND.(nbo == nb(1)*nb(2)*nb(3)) & + & .AND.ALL(ind(1:nbi) <= nbo) ) THEN + ma_fuonly_r31 = 0 + y(1:nbo) = miss_val + isb = nb(1)*nb(2) + DO ij=1,nbi + IF (ind(ij) > 0) THEN + k = ((ind(ij)-1)/isb)+1 + ipp = ind(ij)-(k-1)*isb + j = ((ipp-1)/nb(1))+1 + i = (ipp-(j-1)*nb(1)) + y(ind(ij)) = x(i,j,k) + ENDIF + ENDDO + ELSE + ma_fuonly_r31 = 1 + ENDIF +!------------------------- +END FUNCTION ma_fuonly_r31 +!=== +SUBROUTINE moycum (opp,np,px,py,pwx) +!--------------------------------------------------------------------- +!- Does time operations +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=7) :: opp + INTEGER :: np + REAL,DIMENSION(:) :: px,py + INTEGER :: pwx +!--------------------------------------------------------------------- + IF (pwx /= 0) THEN + IF (opp == 'ave') THEN + px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1) + ELSE IF (opp == 't_sum') THEN + px(1:np)=px(1:np)+py(1:np) + ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN + px(1:np)=MIN(px(1:np),py(1:np)) + ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN + px(1:np)=MAX(px(1:np),py(1:np)) + ELSE + CALL ipslerr(3,"moycum",'Unknown time operation',opp,' ') + ENDIF + ELSE + IF (opp == 'l_min') THEN + px(1:np)=MIN(px(1:np),py(1:np)) + ELSE IF (opp == 'l_max') THEN + px(1:np)=MAX(px(1:np),py(1:np)) + ELSE + px(1:np)=py(1:np) + ENDIF + ENDIF +!-------------------- +END SUBROUTINE moycum +!=== +!----------------- +END MODULE mathelp diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/nc4interface.F90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/nc4interface.F90 new file mode 100644 index 0000000..9f34d48 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/nc4interface.F90 @@ -0,0 +1,124 @@ +MODULE nc4interface +!- +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +#if ! defined key_netcdf4 + !!-------------------------------------------------------------------- + !! 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 +#else + !!-------------------------------------------------------------------- + !! 'key_netcdf4' Dummy module (usually defines dummy routines for netcdf4 + !! calls when compiling without netcdf4 libraries + !!-------------------------------------------------------------------- + + USE netcdf + + !- 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 + INTEGER FUNCTION SET_NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_CHUNKING *** + !! + !! ** Purpose : Interface NetCDF4 routine to enable compiling with NetCDF4 libraries + !! but no key_netcdf4 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: nfid + INTEGER, INTENT(in) :: nvid + INTEGER, INTENT(in) :: ichunkalg + INTEGER, DIMENSION(:), INTENT(in) :: ichunksz + !! + INTEGER :: iret + !! + iret = NF90_DEF_VAR_CHUNKING(nfid, nvid, ichunkalg, ichunksz) + SET_NF90_DEF_VAR_CHUNKING = iret + END FUNCTION SET_NF90_DEF_VAR_CHUNKING + + INTEGER FUNCTION SET_NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) + !!-------------------------------------------------------------------- + !! *** SUBROUTINE NF90_DEF_VAR_DEFLATE *** + !! + !! ** Purpose : Interface NetCDF4 routine to enable compiling with NetCDF4 libraries + !! but no key_netcdf4 + !!-------------------------------------------------------------------- + INTEGER, INTENT(in) :: nfid + INTEGER, INTENT(in) :: nvid + INTEGER, INTENT(in) :: ishuffle + INTEGER, INTENT(in) :: ideflate + INTEGER, INTENT(in) :: ideflate_level + !! + INTEGER :: iret + !! + iret = NF90_DEF_VAR_DEFLATE(nfid, nvid, ishuffle, ideflate, ideflate_level) + SET_NF90_DEF_VAR_DEFLATE = iret + END FUNCTION SET_NF90_DEF_VAR_DEFLATE + + SUBROUTINE GET_NF90_SYMBOL(sym_name, ivalue) + CHARACTER(len=*), INTENT(in) :: sym_name + INTEGER, INTENT(out) :: ivalue + SELECT CASE (sym_name) + CASE ("NF90_HDF5") + ivalue = NF90_HDF5 + CASE DEFAULT + WRITE(*,*) "Warning: unknown case in GET_NF90_SYMBOL" + END SELECT + END SUBROUTINE GET_NF90_SYMBOL +#endif + +!------------------ +END MODULE nc4interface diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/restcom.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/restcom.f90 new file mode 100644 index 0000000..37a2f0f --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/restcom.f90 @@ -0,0 +1,2546 @@ +MODULE restcom +!- +!$Id: restcom.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!- +USE netcdf +!- +USE errioipsl, ONLY : ipslerr,ipsldbg +USE stringop +USE calendar +USE mathelp +USE fliocom, ONLY : flio_dom_file,flio_dom_att +!- +IMPLICIT NONE +!- +PRIVATE +!- +PUBLIC :: & + & restini, restget, restput, restclo, & + & ioconf_setatt, ioget_vname, ioconf_expval, & + & ioget_expval, ioget_vdim +!- +INTERFACE restput + MODULE PROCEDURE & + & restput_r3d, restput_r2d, restput_r1d, & + & restput_opp_r2d, restput_opp_r1d +END INTERFACE +!- +INTERFACE restget + MODULE PROCEDURE & + & restget_r3d,restget_r2d,restget_r1d, & + & restget_opp_r2d,restget_opp_r1d +END INTERFACE +!- +! We do not use allocatable arrays because these sizes are safe +! and we do not know from start how many variables will be in +! the out file. +!- + INTEGER,PARAMETER :: & + & max_var=500, max_file=50, max_dim=NF90_MAX_VAR_DIMS +!- + CHARACTER(LEN=9),SAVE :: calend_str='unknown' +!- +! The IDs of the netCDF files are going in pairs. +! The input one (netcdf_id(?,1)) and the output one (netcdf_id(?,2)) +!- + INTEGER,SAVE :: nb_fi = 0 + INTEGER,DIMENSION(max_file,2),SAVE :: netcdf_id = -1 +!- +! Description of the content of the 'in' files and the 'out' files. +! Number of variables : nbvar_* +! Number of dimensions : nbdim_* +! ID of the time axis : tdimid_* +!- + INTEGER,SAVE :: nbvar_in(max_file), nbvar_out(max_file) + INTEGER,SAVE :: tdimid_in(max_file), tdimid_out(max_file) +!- +! Variables for one or the other file +!- +! Number of dimensions in the input file : nbdim_in +! Number of variables read so far from the input file : nbvar_read +! Type of variable read from the input file : vartyp_in +! (Could be used later to test if we have a restart file) +!- + INTEGER,SAVE :: nbdim_in(max_file), nbvar_read(max_file) + INTEGER,SAVE :: vartyp_in(max_file, max_var) +!- +! Time step and time origine in the input file. +!- + REAL,DIMENSION(max_file),SAVE :: deltat,timeorig +!- +! Description of the axes in the output file +!- +! tstp_out : Index on the tie axis currently beeing written +! itau_out : Time step which is written on this index of the file +!- + INTEGER,DIMENSION(max_file),SAVE :: tstp_out,itau_out +!- +! Description of the axes in the output file +!- +! For the ?ax_infs variable the following order is used : +! ?ax_infs (if,in,1) = size of axis +! ?ax_infs (if,in,2) = id of dimension +! Number of x,y and z axes in the output file : +! ?ax_nb(if) +!- + INTEGER,DIMENSION(max_file,max_dim,2),SAVE :: & + & xax_infs,yax_infs,zax_infs + INTEGER,DIMENSION(max_file),SAVE :: & + & xax_nb=0,yax_nb=0,zax_nb=0 +!- +! Description of the time axes in the input and output files +!- +! ID of the variable which contains the itaus : +! tind_varid_* +! ID of the variables which contains the seconds since date : +! tax_varid_* +! Size of the time axis in the input file : +! tax_size_in +!- + INTEGER,SAVE :: tind_varid_in(max_file), tax_varid_in(max_file), & + & tind_varid_out(max_file), tax_varid_out(max_file) + INTEGER,SAVE :: tax_size_in(max_file)=1 +!- +! The two time axes we have in the input file : +! t_index : dates in itaus +! (thus the variable has a tstep_sec attribute) +! t_julian : Julian days of the time axis +!- + INTEGER,SAVE,ALLOCATABLE :: t_index(:,:) + REAL,SAVE,ALLOCATABLE :: t_julian(:,:) +!- +! Here we save a number of informations on the variables +! in the files we are handling +!- +! Name of variables : varname_* +! ID of the variables : varid_* +! Number of dimensions of the variable : varnbdim_* +! Dimensions which are used for the variable : vardims_* +! Number of attributes for a variables : varatt_* +! A flag which markes the variables we have worked on : touched_* +!- + CHARACTER(LEN=20),DIMENSION(max_file,max_var),SAVE :: & + & varname_in,varname_out + INTEGER,DIMENSION(max_file,max_var),SAVE :: & + & varid_in,varid_out,varnbdim_in,varatt_in + INTEGER,DIMENSION(max_file,max_var,max_dim),SAVE :: & + & vardims_in + LOGICAL,DIMENSION(max_file,max_var),SAVE :: & + & touched_in,touched_out +!- + CHARACTER(LEN=120),SAVE :: indchfun= 'scatter, fill, gather, coll' + REAL,PARAMETER :: missing_val=1.e20 +! or HUGE(1.0) (maximum real number) +!- +! The default value we will use for variables +! which are not present in the restart file +!- + REAL,SAVE :: val_exp = 999999. + LOGICAL,SAVE :: lock_valexp = .FALSE. +!- +! Temporary variables in which we store the attributed which are going +! to be given to a new variable which is going to be defined. +!- + CHARACTER(LEN=80),SAVE :: rest_units='XXXXX',rest_lname='XXXXX' +!- +! For allocations +!- + REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp1,buff_tmp2 +!- +!=== +CONTAINS +!=== +!- +SUBROUTINE restini & + & (fnamein,iim,jjm,lon,lat,llm,lev, & + & fnameout,itau,date0,dt,fid,owrite_time_in,domain_id) +!--------------------------------------------------------------------- +!- This subroutine sets up all the restart process. +!- It will call the subroutine which opens the input +!- and output files. +!- The time step (itau), date of origine (date0) and time step are +!- READ from the input file. +!- A file ID, which is common to the input and output file is returned +!- +!- If fnamein = fnameout then the same file is used for the reading +!- the restart conditions and writing the new restart. +!- +!- A special mode can be switched in with filename='NONE'. +!- This means that no restart file is present. +!- Usefull for creating the first restart file +!- or to get elements in a file without creating an output file. +!- +!- A mode needs to be written in which itau, date0 and dt +!- are given to the restart process and thus +!- written into the output restart file. +!- +!- INPUT +!- +!- fnamein : name of the file for the restart +!- iim : Dimension in x +!- jjm : Dimension in y +!- lon : Longitude in the x,y domain +!- lat : Latitude in the x,y domain +!- llm : Dimension in the vertical +!- lev : Positions of the levels +!- fnameout : +!- +!- OUTPUT +!- +!- itau : Time step of the restart file and at which the model +!- should restart +!- date0 : Time at which itau = 0 +!- dt : time step in seconds between two succesiv itaus +!- fid : File identification of the restart file +!- +!- Optional INPUT arguments +!- +!- owrite_time_in : logical argument which allows to +!- overwrite the time in the restart file +!- domain_id : Domain identifier +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(IN) :: fnamein,fnameout + INTEGER :: iim,jjm,llm,fid,itau + REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) + REAL :: date0,dt + LOGICAL,OPTIONAL :: owrite_time_in + INTEGER,INTENT(IN),OPTIONAL :: domain_id +!- + INTEGER :: ncfid + REAL :: dt_tmp,date0_tmp + LOGICAL :: l_fi,l_fo,l_rw + LOGICAL :: overwrite_time + CHARACTER(LEN=120) :: fname + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 Prepare the configuration before opening any files +!- + IF (.NOT.PRESENT(owrite_time_in)) THEN + overwrite_time = .FALSE. + ELSE + overwrite_time = owrite_time_in + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) 'restini 0.0 : ',TRIM(fnamein),' , ',TRIM(fnameout) + ENDIF +!- + nb_fi = nb_fi+1 +!- + IF (nb_fi > max_file) THEN + CALL ipslerr (3,'restini',& + & 'Too many restart files are used. The problem can be',& + & 'solved by increasing max_file in restcom.f90 ',& + & 'and recompiling ioipsl.') + ENDIF +!- +! 0.1 Define the open flags +!- + l_fi = (TRIM(fnamein) /= 'NONE') + l_fo = (TRIM(fnameout) /= 'NONE') + IF ((.NOT.l_fi).AND.(.NOT.l_fo)) THEN + CALL ipslerr (3,'restini',& + & 'Input and output file names are both to NONE.',& + & 'It is probably an error.','Verify your logic.') + ENDIF + l_rw = l_fi.AND.l_fo.AND.(TRIM(fnamein) == TRIM(fnameout)) +!- + IF (l_dbg) THEN + WRITE(*,*) 'restini 0.1 l_fi, l_fo, l_rw : ',l_fi,l_fo,l_rw + ENDIF +!- +! 1.0 Open the input file. +!- + IF (l_fi) THEN +!--- + IF (l_dbg) WRITE(*,*) 'restini 1.0 : Open input file' +!-- Add DOMAIN number and ".nc" suffix in file names if needed + fname = fnamein + CALL flio_dom_file (fname,domain_id) +!-- Open the file + CALL restopenin (nb_fi,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid) + netcdf_id(nb_fi,1) = ncfid +!--- +!-- 1.3 Extract the time information +!--- + IF (overwrite_time) THEN + date0_tmp = date0 + ENDIF + CALL restsett (dt_tmp,date0_tmp,itau,overwrite_time) + IF (.NOT.overwrite_time) THEN + dt = dt_tmp + date0 = date0_tmp + ENDIF +!--- + ELSE +!--- +!-- 2.0 The case of a missing restart file is dealt with +!--- + IF (l_dbg) WRITE(*,*) 'restini 2.0' +!--- + IF ( (ALL(MINLOC(lon(:iim,:jjm)) == MAXLOC(lon(:iim,:jjm)))) & + .AND.(iim > 1) ) THEN + CALL ipslerr (3,'restini',& + & 'For creating a restart file the longitudes of the',& + & 'grid need to be provided to restini. This ',& + & 'information is needed for the restart files') + ENDIF + IF ( (ALL(MINLOC(lat(:iim,:jjm)) == MAXLOC(lat(:iim,:jjm)))) & + .AND.(jjm > 1) ) THEN + CALL ipslerr (3,'restini',& + & 'For creating a restart file the latitudes of the',& + & 'grid need to be provided to restini. This ',& + & 'information is needed for the restart files') + ENDIF + IF ( (ALL(MINLOC(lev(:llm)) == MAXLOC(lev(:llm)))) & + .AND.(llm > 1) ) THEN + CALL ipslerr (3,'restini',& + & 'For creating a restart file the levels of the',& + & 'grid need to be provided to restini. This',& + & 'information is needed for the restart files') + ENDIF +!--- +!-- 2.2 Allocate the time axes and write the inputed variables +!--- + tax_size_in(nb_fi) = 1 + CALL rest_atim (l_dbg,'restini') + t_index(nb_fi,1) = itau + t_julian(nb_fi,1) = date0 + ENDIF +!- + IF (l_fo.AND.(.NOT.l_rw)) THEN +!-- Add DOMAIN number and ".nc" suffix in file names if needed + fname = fnameout + CALL flio_dom_file (fname,domain_id) +!-- Open the file + CALL restopenout & + (nb_fi,fname,iim,jjm,lon,lat,llm,lev,dt,date0,ncfid,domain_id) + netcdf_id(nb_fi,2) = ncfid + ELSE IF (l_fi.AND.l_fo) THEN + netcdf_id(nb_fi,2) = netcdf_id(nb_fi,1) + varname_out(nb_fi,:) = varname_in(nb_fi,:) + nbvar_out(nb_fi) = nbvar_in(nb_fi) + tind_varid_out(nb_fi) = tind_varid_in(nb_fi) + tax_varid_out(nb_fi) = tax_varid_in(nb_fi) + varid_out(nb_fi,:) = varid_in(nb_fi,:) + touched_out(nb_fi,:) = .TRUE. + ENDIF +!- +! 2.3 Set the calendar for the run. +! This should not produce any error message if +! This does not mean any change in calendar +! (to be modified in ioconf_calendar) +!- + IF (l_dbg) THEN + WRITE(*,*) 'restini 2.3 : Configure calendar if needed : ', & + calend_str + ENDIF +!- + IF (INDEX(calend_str,'unknown') < 1) THEN + CALL ioconf_calendar (calend_str) + IF (l_dbg) THEN + WRITE(*,*) 'restini 2.3b : new calendar : ',calend_str + ENDIF + ENDIF +!- +! Save some data in the module +!- + deltat(nb_fi) = dt +!- +! Prepare the variables which will be returned +!- + fid = nb_fi + IF (l_dbg) THEN + WRITE(*,*) 'SIZE of t_index :',SIZE(t_index), & + SIZE(t_index,dim=1),SIZE(t_index,dim=2) + WRITE(*,*) 't_index = ',t_index(fid,:) + ENDIF + itau = t_index(fid,1) +!- + IF (l_dbg) WRITE(*,*) 'restini END' +!--------------------- +END SUBROUTINE restini +!=== +SUBROUTINE restopenin & + (fid,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid) +!--------------------------------------------------------------------- +!- Opens the restart file and checks that it belongsd to the model. +!- This means that the coordinates of the model are compared to the +!- ones in the file. +!- +!- The number and name of variable in the file are exctracted. Also +!- the time details. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid,iim,jjm,llm + CHARACTER(LEN=*),INTENT(IN) :: fname + REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) + LOGICAL,INTENT(IN) :: l_rw + INTEGER,INTENT(OUT) :: ncfid +!- + INTEGER,DIMENSION(max_dim) :: var_dims,dimlen + INTEGER :: nb_dim,nb_var,id_unl,id,iv + INTEGER :: iread,jread,lread,iret + INTEGER :: lon_vid,lat_vid + REAL :: lon_read(iim,jjm),lat_read(iim,jjm) + REAL :: lev_read(llm) + REAL :: mdlon,mdlat + CHARACTER(LEN=80) :: units + CHARACTER(LEN=NF90_max_name),DIMENSION(max_dim) :: dimname + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! If we reuse the same file for input and output +! then we open it in write mode +!- + IF (l_rw) THEN; id = NF90_WRITE; ELSE; id = NF90_NOWRITE; ENDIF + iret = NF90_OPEN(fname,id,ncfid) + IF (iret /= NF90_NOERR) THEN + CALL ipslerr (3,'restopenin','Could not open file :',fname,' ') + ENDIF +!- + IF (l_dbg) WRITE (*,*) "restopenin 0.0 ",TRIM(fname) + iret = NF90_INQUIRE(ncfid,nDimensions=nb_dim, & + & nVariables=nb_var,unlimitedDimId=id_unl) + tdimid_in(fid) = id_unl +!- + IF (nb_dim > max_dim) THEN + CALL ipslerr (3,'restopenin',& + & 'More dimensions present in file that can be store',& + & 'Please increase max_dim in the global variables ',& + & 'in restcom.F90') + ENDIF + IF (nb_var > max_var) THEN + CALL ipslerr (3,'restopenin',& + & 'More variables present in file that can be store',& + & 'Please increase max_var in the global variables ',& + & 'in restcom.F90') + ENDIF +!- + nbvar_in(fid) = nb_var + nbdim_in(fid) = nb_dim + iread = -1; jread = -1; lread = -1; + DO id=1,nb_dim + iret = NF90_INQUIRE_DIMENSION(ncfid,id, & + & len=dimlen(id),name=dimname(id)) + IF (l_dbg) THEN + WRITE (*,*) "restopenin 0.0 dimname",id,TRIM(dimname(id)) + ENDIF + IF (TRIM(dimname(id)) == 'x') THEN + iread = dimlen(id) + IF (l_dbg) WRITE (*,*) "iread",iread + ELSE IF (TRIM(dimname(id)) == 'y') THEN + jread = dimlen(id) + IF (l_dbg) WRITE (*,*) "jread",jread + ELSE IF (TRIM(dimname(id)) == 'z') THEN + lread = dimlen(id) + IF (l_dbg) WRITE (*,*) "lread",lread + ENDIF + ENDDO +!- + IF (id_unl > 0) THEN +!--- +!-- 0.1 If we are going to add values to this file +!-- we need to know where it ends +!-- We also need to have all the dimensions in the file +!--- + IF (l_rw) THEN + tstp_out(fid) = dimlen(id_unl) + itau_out(fid) = -1 + tdimid_out(fid) = tdimid_in(fid) + IF (l_dbg) THEN + WRITE (*,*) & + & "restopenin 0.0 unlimited axis dimname", & + & dimname(id_unl),tstp_out(fid) + ENDIF +!----- + xax_nb(fid) = 0 + yax_nb(fid) = 0 + zax_nb(fid) = 0 +!----- + DO id=1,nb_dim + IF (dimname(id)(1:1) == 'x') THEN + xax_nb(fid) = xax_nb(fid)+1 + xax_infs(fid,xax_nb(fid),1) = dimlen(id) + xax_infs(fid,xax_nb(fid),2) = id + ELSE IF (dimname(id)(1:1) == 'y') THEN + yax_nb(fid) = yax_nb(fid)+1 + yax_infs(fid,yax_nb(fid),1) = dimlen(id) + yax_infs(fid,yax_nb(fid),2) = id + ELSE IF (dimname(id)(1:1) == 'z') THEN + zax_nb(fid) = zax_nb(fid)+1 + zax_infs(fid,zax_nb(fid),1) = dimlen(id) + zax_infs(fid,zax_nb(fid),2) = id + ENDIF + ENDDO + ENDIF + ELSE +!--- +!-- Still need to find a method for dealing with this +!--- +! CALL ipslerr (3,'restopenin',& +! & ' We do not deal yet with files without time axis.',' ',' ') + ENDIF +!- +! 1.0 First let us check that we have the righ restart file +!- + IF ((iread /= iim).OR.(jread /= jjm).OR.(lread /= llm)) THEN + CALL ipslerr (3,'restopenin',& + & 'The grid of the restart file does not correspond',& + & 'to that of the model',' ') + ENDIF +!- +! 2.0 Get the list of variables +!- + IF (l_dbg) WRITE(*,*) 'restopenin 1.2' +!- + lat_vid = -1 + lon_vid = -1 + tind_varid_in(fid) = -1 + tax_varid_in(fid) = -1 +!- + DO iv=1,nb_var +!--- + varid_in(fid,iv) = iv + var_dims(:) = 0 + iret = NF90_INQUIRE_VARIABLE(ncfid,iv, & + & name=varname_in(fid,iv),xtype=vartyp_in(fid,iv), & + & ndims=varnbdim_in(fid,iv),dimids=var_dims, & + & nAtts=varatt_in(fid,iv)) +!--- + DO id=1,varnbdim_in(fid,iv) + iret = NF90_INQUIRE_DIMENSION & + & (ncfid,var_dims(id),len=vardims_in(fid,iv,id)) + ENDDO +!--- +!-- 2.1 Read the units of the variable +!--- + units='' + iret = NF90_GET_ATT(ncfid,iv,'units',units) + CALL strlowercase (units) + CALL cmpblank (units) +!--- +!-- 2.2 Catch the time variables +!--- + IF (varnbdim_in(fid,iv) == 1) THEN + IF ( (INDEX(units,'timesteps since') > 0) & + .AND.(tind_varid_in(fid) < 0) ) THEN + tind_varid_in(fid) = iv + tax_size_in(fid) = vardims_in(fid,iv,1) + ENDIF + IF ( (INDEX(units,'seconds since') > 0) & + .AND.(tax_varid_in(fid) < 0) ) THEN + tax_varid_in(fid) = iv + tax_size_in(fid) = vardims_in(fid,iv,1) + ENDIF + ENDIF +!--- +!-- 2.3 Catch longitude and latitude variables +!--- + IF (INDEX(units,'degrees_nort') > 0) THEN + lat_vid = iv + ELSE IF (INDEX(units,'degrees_east') > 0) THEN + lon_vid = iv + ENDIF +!--- + ENDDO +!- +! 2.4 None of the variables was yet read +!- + nbvar_read(fid) = 0 + touched_in(fid,:) = .FALSE. +!- +! 3.0 Reading the coordinates from the input restart file +!- + lon_read = missing_val + lat_read = missing_val +!- + IF (lon_vid < 0 .OR. lat_vid < 0) THEN + CALL ipslerr (3,'restopenin',& + & ' No variables containing longitude or latitude were ',& + & ' found in the restart file.',' ') + ELSE + iret = NF90_GET_VAR(ncfid,lon_vid,lon_read) + iret = NF90_GET_VAR(ncfid,lat_vid,lat_read) +!--- + IF ( (ABS( MAXVAL(lon(:,:)) & + & -MINVAL(lon(:,:))) < EPSILON(MAXVAL(lon(:,:)))) & + & .AND.(ABS( MAXVAL(lat(:,:)) & + & -MINVAL(lat(:,:))) < EPSILON(MAXVAL(lat(:,:)))) ) THEN +!----- +!---- 3.1 No longitude nor latitude are provided thus +!---- they are taken from the restart file +!----- + lon(:,:) = lon_read(:,:) + lat(:,:) = lat_read(:,:) + ELSE +!----- +!---- 3.2 We check that the longitudes and latitudes +!---- in the file and the model are the same +!----- + mdlon = MAXVAL(ABS(lon_read-lon)) + mdlat = MAXVAL(ABS(lat_read-lat)) +!----- +!---- We can not test against epsilon here as the longitude +!---- can be stored at another precision in the netCDF file. +!---- The test here does not need to be very precise. +!----- + IF (mdlon > 1.e-4 .OR. mdlat > 1.e-4) THEN + CALL ipslerr (3,'restopenin',& + & ' The longitude or latitude found in the restart ',& + & ' file are not the same as the ones used in the model.',& + & ' ') + ENDIF + ENDIF + ENDIF +!------------------------ +END SUBROUTINE restopenin +!=== +SUBROUTINE restsett (timestep,date0,itau,owrite_time_in) +!--------------------------------------------------------------------- +!- Here we get all the time information from the file. +!- +!- The time information can come in three forms : +!- -global attributes which give the time origine and the +!- time step is taken from the input to restinit +!- -A physical time exists and thus the julian date from the +!- input is used for positioning using the itau as input +!- -A time-step axis exists and itau is positioned on it. +!- +!- What takes precedence : the model +!- +!- itau : Time step of the model +!- +!- Optional INPUT arguments +!- +!- owrite_time_in : logical argument which allows to +!- overwrite the time in the restart file +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL :: date0,timestep + INTEGER :: itau + LOGICAL,OPTIONAL :: owrite_time_in +!- + INTEGER :: ncfid,iret,it,iax,iv + CHARACTER(LEN=80) :: itau_orig,tax_orig,calendar + CHARACTER(LEN=9) :: tmp_cal + INTEGER :: year0,month0,day0,hours0,minutes0,seci + REAL :: sec0,one_day,one_year,date0_ju,ttmp + CHARACTER :: strc + LOGICAL :: ow_time + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (PRESENT(owrite_time_in)) THEN + ow_time = owrite_time_in + ELSE + ow_time = .FALSE. + ENDIF +!- + ncfid = netcdf_id(nb_fi,1) +!- +! Allocate the space we need for the time axes +!- + CALL rest_atim (l_dbg,'restsett') +!- +! Get the calendar if possible. Else it will be gregorian. +!- + IF (tax_size_in(nb_fi) > 0) THEN + calendar = ' ' + iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',calendar) + IF (iret == NF90_NOERR) THEN + CALL ioconf_calendar (calendar) + IF (l_dbg) THEN + WRITE(*,*) 'restsett : calendar of the restart ',calendar + ENDIF + ENDIF + ENDIF + CALL ioget_calendar (one_year,one_day) + IF (l_dbg) THEN + WRITE(*,*) 'one_year,one_day = ',one_year,one_day + ENDIF +!- + itau_orig = 'XXXXX' + tax_orig = 'XXXXX' +!- +! Get the time steps of the time axis if available on the restart file +!- + IF (tind_varid_in(nb_fi) > 0) THEN + IF (ow_time) THEN + t_index(nb_fi,:) = itau + IF (l_dbg) THEN + WRITE(*,*) "nb_fi,t_index",nb_fi,t_index(nb_fi,:) + ENDIF + CALL ju2ymds (date0,year0,month0,day0,sec0) + hours0 = NINT(sec0/3600) + sec0 = sec0 - 3600 * hours0 + minutes0 = NINT(sec0 / 60) + sec0 = sec0 - 60 * minutes0 + seci = NINT(sec0) + strc=':' + IF (l_dbg) THEN + WRITE(*,*) date0 + WRITE (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') & + & year0,'-',month0,'-',day0,' ',hours0,':',minutes0,':',seci + WRITE(*,*) "itau_orig : ",itau_orig + ENDIF + ELSE + iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:)) + IF (l_dbg) THEN + WRITE(*,*) "restsett, time axis : ",t_index(nb_fi,:) + ENDIF + iret = NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'units',itau_orig) + itau_orig = & + & itau_orig(INDEX(itau_orig,'since')+6:LEN_TRIM(itau_orig)) + iret = & + & NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'tstep_sec',timestep) +!----- +!---- This time origin will dominate as it is linked to the time steps. +!----- + READ (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') & + & year0,strc,month0,strc,day0,strc, & + & hours0,strc,minutes0,strc,seci + sec0 = REAL(seci) + sec0 = hours0*3600.+minutes0*60.+sec0 + CALL ymds2ju (year0,month0,day0,sec0,date0) + ENDIF + ENDIF +!- +! If a julian day time axis is available then we get it +!- + IF (tax_varid_in(nb_fi) > 0) THEN + iret = NF90_GET_VAR(ncfid,tax_varid_in(nb_fi),t_julian(nb_fi,:)) + iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'units',tax_orig) + tax_orig = tax_orig(INDEX(tax_orig,'since')+6:LEN_TRIM(tax_orig)) + tmp_cal = ' ' + iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',tmp_cal) + IF (l_dbg) THEN + WRITE(*,*) 'restsett : tmp_calendar of the restart ',tmp_cal + ENDIF +!--- + CALL strlowercase (tmp_cal) + IF (INDEX(calend_str,tmp_cal) < 1) THEN + IF (INDEX(calend_str,'unknown') > 0) THEN + calend_str = tmp_cal + ELSE + CALL ipslerr (2,'restsett', & + & ' In the restart files two different calendars were found.', & + & ' Please check the files you have used.',' ') + ENDIF + ENDIF +!--- +!-- We need to transform that into julian days +!-- to get ride of the intial date. +!--- + IF (l_dbg) WRITE(*,*) 'tax_orig : ',TRIM(tax_orig) + READ (UNIT=tax_orig,FMT='(I4.4,5(a,I2.2))') & + year0,strc,month0,strc,day0,strc, & + hours0,strc,minutes0,strc,seci + sec0 = REAL(seci) + sec0 = hours0*3600.+minutes0*60.+sec0 + CALL ymds2ju (year0,month0,day0,sec0,date0_ju) + t_julian(nb_fi,:) = t_julian(nb_fi,:)/one_day+date0_ju + ENDIF +!- + IF ( (INDEX(itau_orig,'XXXXX') > 0) & + .AND.(INDEX(tax_orig,'XXXXX') < 1) ) THEN +!!- Compute the t_itau from the date read and the timestep in the input + ENDIF +!- + IF ( (INDEX(tax_orig,'XXXXX') > 0) & + .AND.(INDEX(itau_orig,'XXXXX') < 1) ) THEN + DO it=1,tax_size_in(nb_fi) + t_julian(nb_fi,it) = itau2date(t_index(nb_fi,it),date0,timestep) + ENDDO + ENDIF +!- +! If neither the indices or time is present then get global attributes +! This is for compatibility reasons and should not be used. +!- + IF ((tax_varid_in(nb_fi) < 0).AND.(tind_varid_in(nb_fi) < 0)) THEN + iax = -1 + DO iv=1,nbvar_in(nb_fi) + IF ( (INDEX(varname_in(nb_fi,iv),'tsteps') > 0) & + & .OR.(INDEX(varname_in(nb_fi,iv),'time_steps') > 0)) THEN + iax = iv + ENDIF + ENDDO +!--- + IF (iax < 0) THEN + CALL ipslerr (3,'restsett',& + & 'No time axis was found in the restart file. Please check',& + & 'that it corresponds to the convention used in restsett',& + & ' ') + ELSE + iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:)) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'delta_tstep_sec',timestep) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'year0',ttmp) + year0 = NINT(ttmp) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'month0',ttmp) + month0 = NINT(ttmp) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'day0',ttmp) + day0 = NINT(ttmp) + iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'sec0',sec0) +!--- + CALL ymds2ju (year0,month0,day0,sec0,date0) + t_julian(nb_fi,1) = itau2date(t_index(nb_fi,1),date0,timestep) + ENDIF + ENDIF +!---------------------- +END SUBROUTINE restsett +!=== +SUBROUTINE restopenout & + (fid,fname,iim,jjm, & + lon,lat,llm,lev,timestep,date,ncfid,domain_id) +!--------------------------------------------------------------------- +!- Opens the restart file for output. +!- The longitude and time variables are written. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid,iim,jjm,llm + CHARACTER(LEN=*) :: fname + REAL :: date,timestep + REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm) + INTEGER,INTENT(OUT) :: ncfid + INTEGER,INTENT(IN),OPTIONAL :: domain_id +!- + INTEGER :: iret + CHARACTER(LEN=70) :: str_t + INTEGER :: x_id,y_id,z_id,itauid + INTEGER :: nlonid,nlatid,nlevid,timeid + INTEGER :: year,month,day,hours,minutes + REAL :: sec + CHARACTER(LEN=3),DIMENSION(12) :: & + cal = (/'JAN','FEB','MAR','APR','MAY','JUN', & + 'JUL','AUG','SEP','OCT','NOV','DEC'/) + CHARACTER(LEN=30) :: timenow + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (l_dbg) WRITE(*,*) "restopenout 0.0 ",TRIM(fname) +!- +! If we use the same file for input and output +!- we will not even call restopenout +!- + iret = NF90_CREATE(fname,NF90_NOCLOBBER,ncfid) + IF (iret == -35) THEN + CALL ipslerr (3,'restopenout',& + & ' The restart file aready exists on the disc. IOIPSL ',& + & ' will not overwrite it. You should remove the old one or ',& + & ' generate the new one with another name') + ENDIF +!- + iret = NF90_DEF_DIM(ncfid,'x',iim,x_id) + xax_nb(fid) = xax_nb(fid)+1 + xax_infs(fid,xax_nb(fid),1) = iim + xax_infs(fid,xax_nb(fid),2) = x_id +!- + iret = NF90_DEF_DIM(ncfid,'y',jjm,y_id) + yax_nb(fid) = yax_nb(fid)+1 + yax_infs(fid,yax_nb(fid),1) = jjm + yax_infs(fid,yax_nb(fid),2) = y_id +!- + iret = NF90_DEF_DIM(ncfid,'z',llm,z_id) + zax_nb(fid) = zax_nb(fid)+1 + zax_infs(fid,zax_nb(fid),1) = llm + zax_infs(fid,zax_nb(fid),2) = z_id +!- + iret = NF90_DEF_DIM(ncfid,'time',NF90_UNLIMITED,tdimid_out(fid)) +!- +! 1.0 Longitude +!- + IF (l_dbg) WRITE(*,*) "restopenout 1.0" +!- + iret = NF90_DEF_VAR(ncfid,"nav_lon",NF90_FLOAT,(/x_id,y_id/),nlonid) + iret = NF90_PUT_ATT(ncfid,nlonid,'units',"degrees_east") + iret = NF90_PUT_ATT(ncfid,nlonid,'valid_min',REAL(-180.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlonid,'valid_max',REAL( 180.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlonid,'long_name',"Longitude") +!- +! 2.0 Latitude +!- + IF (l_dbg) WRITE(*,*) "restopenout 2.0" +!- + iret = NF90_DEF_VAR(ncfid,"nav_lat",NF90_FLOAT,(/x_id,y_id/),nlatid) + iret = NF90_PUT_ATT(ncfid,nlatid,'units',"degrees_north") + iret = NF90_PUT_ATT(ncfid,nlatid,'valid_min',REAL(-90.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlatid,'valid_max',REAL( 90.,KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlatid,'long_name',"Latitude") +!- +! 3.0 Levels +!- + IF (l_dbg) WRITE(*,*) "restopenout 3.0" +!- + iret = NF90_DEF_VAR(ncfid,"nav_lev",NF90_FLOAT,z_id,nlevid) + iret = NF90_PUT_ATT(ncfid,nlevid,'units',"model_levels") + iret = NF90_PUT_ATT(ncfid,nlevid,'valid_min', & + & REAL(MINVAL(lev),KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlevid,'valid_max', & + & REAL(MAXVAL(lev),KIND=4)) + iret = NF90_PUT_ATT(ncfid,nlevid,'long_name',"Model levels") +!- +! 4.0 Time axis, this is the seconds since axis +!- + IF (l_dbg) WRITE(*,*) "restopenout 4.0" +!- + iret = NF90_DEF_VAR(ncfid,"time",NF90_FLOAT, & + tdimid_out(fid),timeid) + tax_varid_out(fid) = timeid +!- + timeorig(fid) = date + CALL ju2ymds (date,year,month,day,sec) + hours = INT(sec/(60.*60.)) + minutes = INT((sec-hours*60.*60.)/60.) + sec = sec-(hours*60.*60.+minutes*60.) + WRITE (UNIT=str_t, & + FMT='("seconds since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') & + & year,month,day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT(ncfid,timeid,'units',TRIM(str_t)) +!- + CALL ioget_calendar (str_t) + iret = NF90_PUT_ATT(ncfid,timeid,'calendar',TRIM(str_t)) + iret = NF90_PUT_ATT(ncfid,timeid,'title','Time') + iret = NF90_PUT_ATT(ncfid,timeid,'long_name','Time axis') +!- + WRITE(UNIT=str_t, & + FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') & + & year,cal(month),day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT(ncfid,timeid,'time_origin',TRIM(str_t)) +!- +! 5.0 Time axis, this is the time steps since axis +!- + IF (l_dbg) WRITE(*,*) "restopenout 5.0" +!- + iret = NF90_DEF_VAR(ncfid,"time_steps",NF90_INT, & + & tdimid_out(fid),itauid) + tind_varid_out(fid) = itauid +!- + CALL ju2ymds (date,year,month,day,sec) +!- + hours = INT(sec/(60.*60.)) + minutes = INT((sec-hours*60.*60.)/60.) + sec = sec-(hours*60.*60.+minutes*60.) +!- + WRITE (UNIT=str_t, & + FMT='("timesteps since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') & + & year,month,day,hours,minutes,INT(sec) +!- + iret = NF90_PUT_ATT(ncfid,itauid,'units',TRIM(str_t)) + iret = NF90_PUT_ATT(ncfid,itauid,'title','Time steps') + iret = NF90_PUT_ATT(ncfid,itauid,'tstep_sec',REAL(timestep,KIND=4)) + iret = NF90_PUT_ATT(ncfid,itauid,'long_name','Time step axis') +!- + WRITE(UNIT=str_t, & + FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') & + & year,cal(month),day,hours,minutes,INT(sec) + iret = NF90_PUT_ATT(ncfid,itauid,'time_origin',TRIM(str_t)) +!- +! 5.2 Write global attributes +!- + iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'Conventions',"CF-1.1") + iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'file_name',TRIM(fname)) +!! TO BE DONE LATER +!! iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL, & +!! 'production',TRIM(model_name)) +!! lock_modname = .TRUE. + CALL ioget_timestamp (timenow) + iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow)) +!- +! Add DOMAIN attributes if needed +!- + CALL flio_dom_att (ncfid,domain_id) +!- +! 6.0 The coordinates are written to the file +!- + iret = NF90_ENDDEF(ncfid) +!- + iret = NF90_PUT_VAR(ncfid,nlonid,lon) + iret = NF90_PUT_VAR(ncfid,nlatid,lat) + iret = NF90_PUT_VAR(ncfid,nlevid,lev) +!- +! 7.0 Set a few variables related to the out file +!- + nbvar_out(fid) = 0 + itau_out(fid) = -1 + tstp_out(fid) = 0 + touched_out(fid,:) = .FALSE. +!- +! 7.1 The file is put back in define mode. +! This will last until itau_out >= 0 +!- + iret = NF90_REDEF(ncfid) +!- + IF (l_dbg) WRITE(*,*) "restopenout END" +!------------------------- +END SUBROUTINE restopenout +!=== +SUBROUTINE restget_opp_r1d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha, & + & var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!- +!- Should work as restput_opp_r1d but the other way around ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL def_beha + REAL :: var(:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: req_sz,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF (nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'resget_opp_r1d', & + 'Unable to performe an operation on this variable as it has',& + 'a second and third dimension',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r1d') + CALL rest_alloc (2,req_sz,l_dbg,'restget_opp_r1d') +!- +! 2.0 Here we get the variable from the restart file +!- + CALL restget_real & + (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + zax_infs(fid,1,1),itau,def_beha,buff_tmp2) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + CALL mathop (topp,req_sz,buff_tmp2,missing_val, & + & nbindex,ijndex,scal,siz1,buff_tmp1) + var(:) = buff_tmp1(1:siz1) + ELSE + CALL ipslerr (3,'resget_opp_r1d', & + 'The operation you wish to do on the variable for the ',& + 'restart file is not allowed.',topp) + ENDIF +!----------------------------- +END SUBROUTINE restget_opp_r1d +!=== +SUBROUTINE restget_opp_r2d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha, & + & var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!- +!- Should work as restput_opp_r2d but the other way around ! +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL def_beha + REAL :: var(:,:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: jj,req_sz,ist,var_sz,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF (nbindex == iim .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'resget_opp_r2d', & + 'Unable to performe an operation on this variable as it has', & + 'a second and third dimension',vname_q) + ENDIF +!- + IF (jjm < 1) THEN + CALL ipslerr (3,'resget_opp_r2d', & + 'Please specify a second dimension which is the', & + 'layer on which the operations are performed',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r2d') + CALL rest_alloc (2,req_sz*jjm,l_dbg,'restget_opp_r2d') +!- +! 2.0 Here we get the full variable from the restart file +!- + CALL restget_real & + & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + & jjm,itau,def_beha,buff_tmp2) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + var_sz = siz1 + DO jj = 1,jjm + ist = (jj-1)*req_sz+1 + CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), & + & missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1) + var(:,jj) = buff_tmp1(1:siz1) + ENDDO + ELSE + CALL ipslerr (3,'resget_opp_r2d', & + 'The operation you wish to do on the variable for the ',& + 'restart file is not allowed.',topp) + ENDIF +!----------------------------- +END SUBROUTINE restget_opp_r2d +!=== +SUBROUTINE restget_r1d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL :: def_beha + REAL :: var(:) +!- + INTEGER :: ji,jl,req_sz,var_sz,siz1 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + var_sz = siz1 + CALL rest_alloc (1,var_sz,l_dbg,'restget_r1d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable requested from file should be ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable can only hold ",I6)') var_sz + CALL ipslerr (3,'restget_r1d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str, & + & '("the size of variable requested from file is ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable can hold ",I6)') var_sz + CALL ipslerr (2,'restget_r1d', & + 'There could be a problem here :',str,str2) + ENDIF +!- + CALL restget_real & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO ji=1,siz1 + jl=jl+1 + var(ji) = buff_tmp1(jl) + ENDDO +!------------------------- +END SUBROUTINE restget_r1d +!=== +SUBROUTINE restget_r2d & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL :: def_beha + REAL :: var(:,:) +!- + INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + var_sz = siz1*siz2 + CALL rest_alloc (1,var_sz,l_dbg,'restget_r2d') +!- +! 2.0 Here we check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file should be ",I6)') TRIM(vname_q),req_sz + WRITE(str2, & + & '("but the provided variable can only hold ",I6)') var_sz + CALL ipslerr (3,'restget_r2d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file is ",I6)') TRIM(vname_q),req_sz + WRITE(str2,'("but the provided variable can hold ",I6)') var_sz + CALL ipslerr (2,'restget_r2d', & + 'There could be a problem here :',str,str2) + ENDIF +!- + CALL restget_real & + & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + var(ji,jj) = buff_tmp1(jl) + ENDDO + ENDDO +!------------------------- +END SUBROUTINE restget_r2d +!=== +SUBROUTINE restget_r3d & + (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restget_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL def_beha + REAL :: var(:,:,:) +!- + INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + siz3 = SIZE(var,3) + var_sz = siz1*siz2*siz3 + CALL rest_alloc (1,var_sz,l_dbg,'restget_r3d') +!- +! 2.0 Here we check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file should be ",I6)') TRIM(vname_q),req_sz + WRITE(str2, & + & '("but the provided variable can only hold ",I6)') var_sz + CALL ipslerr (3,'restget_r3d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str, & + & '("Size of variable ",A, & + & //" requested from file is ",I6)') TRIM(vname_q),req_sz + WRITE(str2,'("but the provided variable can hold ",I6)') var_sz + CALL ipslerr (2,'restget_r3d', & + 'There could be a problem here :',str,str2) + ENDIF +!- + CALL restget_real & + (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1) +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jk=1,siz3 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + var(ji,jj,jk) = buff_tmp1(jl) + ENDDO + ENDDO + ENDDO +!------------------------- +END SUBROUTINE restget_r3d +!=== +SUBROUTINE restget_real & + (fid,vname_q,iim,jjm,llm,itau,def_beha,var) +!--------------------------------------------------------------------- +!- This subroutine is for getting a variable from the restart file. +!- A number of verifications will be made : +!- - Is this the first time we read this variable ? +!- - Are the dimensions correct ? +!- - Is the correct time step present in the file +!- - is a default behaviour possible. If not the model is stoped. +!- Default procedure is to write the content of val_exp on all values. +!- +!- INPUT +!- +!- fid : Identification of the file +!- vname_q : Name of the variable to be read +!- iim, jjm ,llm : Dimensions of the variable that should be read +!- itau : Time step at whcih we are when we want +!- to read the variable +!- def_beha : If the model can restart without this variable +!- then some strange value is given. +!- +!- OUTPUT +!- +!- var : Variable in which the data is put +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + LOGICAL :: def_beha + REAL :: var(:) +!- + INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia + CHARACTER(LEN=70) str,str2 + CHARACTER(LEN=80) attname + INTEGER,DIMENSION(4) :: corner,edge +!--------------------------------------------------------------------- + ncfid = netcdf_id(fid,1) +!- + CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb) +!- +! 1.0 If the variable is not present then ERROR or filled up +! by default values if allowed +!- + IF (vnb < 0) THEN + IF (def_beha) THEN +!----- + lock_valexp = .TRUE. + var(:) = val_exp +!---- + str = 'Variable '//TRIM(vname_q) & + //' is not present in the restart file' + CALL ipslerr (1,'restget', & + & str,'but default values are used to fill in',' ') +!---- + IF (nbvar_in(fid) >= max_var) THEN + CALL ipslerr (3,'restget', & + 'Too many variables for the restcom module', & + 'Please increase the value of max_var',' ') + ENDIF + nbvar_in(fid) = nbvar_in(fid)+1 + vnb = nbvar_in(fid) + varname_in(fid,vnb) = vname_q + touched_in(fid,vnb) = .TRUE. +!----- + CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.) +!----- + ELSE + str = 'Variable '//TRIM(vname_q) & + //' is not present in the restart file' + CALL ipslerr (3,'restget', & + & str,'but it is need to restart the model',' ') + ENDIF +!--- + ELSE +!--- +!-- 2.0 Check if the variable has not yet been read +!-- and that the time is OK +!--- + vid = varid_in(fid,vnb) +!--- + nbvar_read(fid) = nbvar_read(fid)+1 +!--- + IF (touched_in(fid,vnb)) THEN + str = 'Variable '//TRIM(vname_q) & + //' has already been read from file' + CALL ipslerr (3,'restget',str,' ',' ') + ENDIF +!--- +!-- 3.0 get the time step of the restart file +!-- and check if it is correct +!--- + index = -1 + DO it=1,tax_size_in(fid) + IF (t_index(fid,it) == itau) index = it + ENDDO + IF (index < 0) THEN + str = 'The time step requested for variable '//TRIM(vname_q) + CALL ipslerr (3,'restget', & + & str,'is not available in the current file',' ') + ENDIF +!--- +!-- 4.0 Read the data. Note that the variables in the restart files +!-- have no time axis is and thus we write -1 +!--- + str='Incorrect dimension for '//TRIM(vname_q) + ndim = 0 + IF (iim > 0) THEN + ndim = ndim+1 + IF (vardims_in(fid,vnb,ndim) == iim) THEN + corner(ndim) = 1 + edge(ndim) = iim + ELSE + WRITE (str2,'("Incompatibility for iim : ",I6,I6)') & + iim,vardims_in(fid,vnb,ndim) + CALL ipslerr (3,'restget',str,str2,' ') + ENDIF + ENDIF +!--- + IF (jjm > 0) THEN + ndim = ndim+1 + IF (vardims_in(fid,vnb,ndim) == jjm) THEN + corner(ndim) = 1 + edge(ndim) = jjm + ELSE + WRITE (str2,'("Incompatibility for jjm : ",I6,I6)') & + jjm,vardims_in(fid,vnb,ndim) + CALL ipslerr (3,'restget',str,str2,' ') + ENDIF + ENDIF +!--- + IF (llm > 0) THEN + ndim = ndim+1 + IF (vardims_in(fid,vnb,ndim) == llm) THEN + corner(ndim) = 1 + edge(ndim) = llm + ELSE + WRITE (str2,'("Incompatibility for llm : ",I6,I6)') & + llm,vardims_in(fid,vnb,ndim) + CALL ipslerr (3,'restget',str,str2,' ') + ENDIF + ENDIF +!--- +!-- Time +!--- + ndim = ndim+1 + corner(ndim) = index +!!????? edge(ndim) = index + edge(ndim) = 1 +!--- + iret = NF90_GET_VAR(ncfid,vid,var, & + & start=corner(1:ndim),count=edge(1:ndim)) +!--- +!-- 5.0 The variable we have just read is created +!-- in the next restart file +!--- + IF ( (netcdf_id(fid,1) /= netcdf_id(fid,2)) & + & .AND.(netcdf_id(fid,2) > 0) ) THEN +!----- + CALL restdefv (fid,vname_q,iim,jjm,llm,.FALSE.) +!----- + DO ia = 1,varatt_in(fid,vnb) + iret = NF90_INQ_ATTNAME(ncfid,vid,ia,attname) + iret = NF90_COPY_ATT(ncfid,vid,attname, & + & netcdf_id(fid,2),varid_out(fid,nbvar_out(fid))) + ENDDO +!----- + IF (itau_out(fid) >= 0) THEN + iret = NF90_ENDDEF(netcdf_id(fid,2)) + ENDIF + ENDIF +!--- + ENDIF +!-------------------------- +END SUBROUTINE restget_real +!=== +SUBROUTINE restput_opp_r1d & + & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine is the interface to restput_real which allows +!- to re-index data onto the original grid of the restart file. +!- The logic we use is still fuzzy in my mind but that is probably +!- only because I have not yet though through everything. +!- +!- In the case iim = nbindex it means that the user attempts +!- to project a vector back onto the original 2D or 3D field. +!- This requires that jjm and llm be equal to 1 or 0, +!- else I would not know what it means. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: req_sz,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF ( nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'restput_opp_r1d', & + 'Unable to performe an operation on this variable as it has', & + 'a second and third dimension',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r1d') + CALL rest_alloc (2,req_sz,l_dbg,'restput_opp_r1d') +!- +! 2.0 We do the operation needed. +! It can only be a re-indexing operation. +! You would not want to change the values in a restart file or ? +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + buff_tmp1(1:siz1) = var(:) + CALL mathop & + & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & + & scal,req_sz,buff_tmp2) + ELSE + CALL ipslerr (3,'restput_opp_r1d', & + & 'The operation you wish to do on the variable for the ', & + & 'restart file is not allowed.',topp) + ENDIF +!- + CALL restput_real & + & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + & zax_infs(fid,1,1),itau,buff_tmp2) +!----------------------------- +END SUBROUTINE restput_opp_r1d +!=== +SUBROUTINE restput_opp_r2d & + & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex) +!--------------------------------------------------------------------- +!- This subroutine is the interface to restput_real which allows +!- to re-index data onto the original grid of the restart file. +!- The logic we use is still fuzzy in my mind but that is probably +!- only because I have not yet though through everything. +!- +!- In the case iim = nbindex it means that the user attempts +!- to project the first dimension of the matrix back onto a 3D field +!- where jjm will be the third dimension. +!- Here we do not allow for 4D data, thus we will take the first +!- two dimensions in the file and require that llm = 1. +!- These are pretty heavy constraints but I do not know how +!- to make it more general. I need to think about it some more. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:,:) + CHARACTER(LEN=*) :: MY_OPERATOR + INTEGER :: nbindex,ijndex(nbindex) +!- + INTEGER :: jj,req_sz,ist,siz1 + REAL :: scal + CHARACTER(LEN=7) :: topp + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 What size should be the data in the file +!- + req_sz = 1 + IF ( nbindex == iim .AND. llm <= 1) THEN + IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1) + IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1) + ELSE + CALL ipslerr (3,'restput_opp_r2d', & + 'Unable to performe an operation on this variable as it has', & + 'a second and third dimension',vname_q) + ENDIF +!- + IF (jjm < 1) THEN + CALL ipslerr (3,'restput_opp_r2d', & + 'Please specify a second dimension which is the', & + 'layer on which the operations are performed',vname_q) + ENDIF +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r2d') + CALL rest_alloc (2,req_sz*jjm,l_dbg,'restput_opp_r2d') +!- +! 2.0 We do the operation needed. +! It can only be a re-indexing operation. +! You would not want to change the values in a restart file or ? +!- + topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7)) +!- + IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN + scal = missing_val + DO jj = 1,jjm + buff_tmp1(1:siz1) = var(:,jj) + ist = (jj-1)*req_sz+1 + CALL mathop & + & (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, & + & scal,req_sz,buff_tmp2(ist:ist+req_sz-1)) + ENDDO + ELSE + CALL ipslerr (3,'restput_opp_r2d', & + & 'The operation you wish to do on the variable for the ', & + & 'restart file is not allowed.',topp) + ENDIF +!- + CALL restput_real & + & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), & + & jjm,itau,buff_tmp2) +!----------------------------- +END SUBROUTINE restput_opp_r2d +!=== +SUBROUTINE restput_r1d (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restput_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:) +!- + INTEGER :: ji,jl,req_sz,var_sz,siz1 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var) + var_sz = siz1 + CALL rest_alloc (1,var_sz,l_dbg,'restput_r1d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable put to the file should be ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable is of size ",I6)') var_sz + CALL ipslerr (3,'restput_r1d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str,'("the size of variable put to the file is ",I6)') req_sz + WRITE(str2,'("but the provided variable is larger ",I6)') var_sz + CALL ipslerr (2,'restput_r1d', & + 'There could be a problem here :',str,str2) + ENDIF +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO ji=1,siz1 + jl=jl+1 + buff_tmp1(jl) = var(ji) + ENDDO +!- + CALL restput_real (fid,vname_q,iim,jjm,llm,itau,buff_tmp1) +!------------------------- +END SUBROUTINE restput_r1d +!=== +SUBROUTINE restput_r2d (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restput_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:,:) +!- + INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + var_sz = siz1*siz2 + CALL rest_alloc (1,var_sz,l_dbg,'restput_r2d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & +& '("Size of variable put to the file should be ",I6)') req_sz + WRITE(str2,'("but the provided variable is of size ",I6)') var_sz + CALL ipslerr (3,'restput_r2d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str,'("the size of variable put to the file is ",I6)') req_sz + WRITE(str2,'("but the provided variable is larger ",I6)') var_sz + CALL ipslerr (2,'restput_r2d', & + 'There could be a problem here :',str,str2) + ENDIF +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + buff_tmp1(jl) = var(ji,jj) + ENDDO + ENDDO +!- + CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1) +!------------------------- +END SUBROUTINE restput_r2d +!=== +SUBROUTINE restput_r3d (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine serves as an interface to restput_real +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER :: iim,jjm,llm,itau + REAL :: var(:,:,:) +!- + INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3 + CHARACTER(LEN=70) :: str,str2 + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 1.0 Allocate the temporary buffer we need +! to put the variable in right dimension +!- + siz1 = SIZE(var,1) + siz2 = SIZE(var,2) + siz3 = SIZE(var,3) + var_sz = siz1*siz2*siz3 + CALL rest_alloc (1,var_sz,l_dbg,'restput_r3d') +!- +! 2.0 Here we could check if the sizes specified agree +! with the size of the variable provided +!- + req_sz = 1 + IF (iim > 0) req_sz = req_sz*iim + IF (jjm > 0) req_sz = req_sz*jjm + IF (llm > 0) req_sz = req_sz*llm + IF (req_sz > var_sz) THEN + WRITE(str, & + & '("Size of variable put to the file should be ",I6)') req_sz + WRITE(str2, & + & '("but the provided variable is of size ",I6)') var_sz + CALL ipslerr (3,'restput_r3d',str,str2,' ') + ENDIF + IF (req_sz < var_sz) THEN + WRITE(str,'("the size of variable put to the file is ",I6)') req_sz + WRITE(str2,'("but the provided variable is larger ",I6)') var_sz + CALL ipslerr (2,'restput_r3d', & + 'There could be a problem here :',str,str2) + ENDIF +!- +! 4.0 Transfer the buffer obtained from the restart file +! into the variable the model expects +!- + jl=0 + DO jk=1,siz3 + DO jj=1,siz2 + DO ji=1,siz1 + jl=jl+1 + buff_tmp1(jl) = var(ji,jj,jk) + ENDDO + ENDDO + ENDDO +!- + CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1) +!------------------------- +END SUBROUTINE restput_r3d +!=== +SUBROUTINE restput_real (fid,vname_q,iim,jjm,llm,itau,var) +!--------------------------------------------------------------------- +!- This subroutine will put a variable into the restart file. +!- But it will do a lot of other things if needed : +!- - Open a file if non is opened for this time-step +!- and all variables were written. +!- - Add an axis if needed +!- - verify that the variable has the right time step for this file +!- - If it is time for a new file then it is opened +!- and the old one closed +!- This requires that variables read from the last restart file were all +!- written +!- +!- INPUT +!- +!- fid : Id of the file in which we will write the variable +!- vname_q : Name of the variable to be written +!- iim,jjm,llm : Size in 3D of the variable +!- itau : Time step at which the variable is written +!- var : Variable +!- +!- OUTPUT +!- +!- NONE +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: vname_q + INTEGER :: fid,iim,jjm,llm,itau + REAL :: var(:) +!- + INTEGER :: iret,vid,ncid,iv,vnb + INTEGER :: ierr + REAL :: secsince,one_day,one_year + INTEGER :: ndims + INTEGER,DIMENSION(4) :: corner,edge + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- +! 0.0 Get some variables +!- + ncid = netcdf_id(fid,2) + IF (netcdf_id(fid,2) < 0) THEN + CALL ipslerr (3,'restput', & + & 'The output restart file is undefined.',' ',' ') + ENDIF + CALL ioget_calendar (one_year,one_day) +!- +! 1.0 Check if the variable is already present +!- + IF (l_dbg) WRITE(*,*) 'RESTPUT 1.0 : ',TRIM(vname_q) +!- + CALL find_str (varname_out(fid,1:nbvar_out(fid)),vname_q,vnb) +!- + IF (l_dbg) THEN + WRITE(*,*) 'RESTPUT 1.1 : ',varname_out(fid,1:nbvar_out(fid)),vnb + ENDIF +!- +! 2.0 If variable is not present then declare it +! and add extra dimensions if needed. +!- + IF (vnb <= 0) THEN + CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.) + vnb = nbvar_out(fid) + ENDIF + vid = varid_out(fid,vnb) +!- + IF (l_dbg) WRITE(*,*) 'RESTPUT 2.0 : ',vnb,vid +!- +! 2.1 Is this file already in write mode ? +! If itau_out is still negative then we have +! never written to it and we need to go into write mode. +!- + IF (itau_out(fid) < 0) THEN + iret = NF90_ENDDEF(ncid) + ENDIF +!- +! 3.0 Is this itau already on the axis ? +! If not then check that all variables of previous time is OK. +!- + IF (l_dbg) WRITE(*,*) 'RESTPUT 3.0 : ',itau,itau_out(fid) +!- + IF (itau /= itau_out(fid)) THEN +!--- +!-- If it is the first time step written on the restart +!-- then we only check the number +!-- Else we see if every variable was written +!--- + IF (tstp_out(fid) == 0) THEN + IF (nbvar_out(fid) < nbvar_read(fid)) THEN + WRITE(*,*) "ERROR :",tstp_out(fid), & + nbvar_out(fid),nbvar_read(fid) + CALL ipslerr (1,'restput', & + & 'There are fewer variables read from the output file', & + & 'than written onto the input file.', & + & 'We trust you know what you are doing') + ENDIF + ELSE + ierr = 0 + DO iv=1,nbvar_out(fid) + IF (.NOT.touched_out(fid,iv)) ierr = ierr+1 + ENDDO + IF (ierr > 0) THEN + WRITE(*,*) "ERROR :",nbvar_out(fid) + CALL ipslerr (1,'restput', & + & 'There are fewer variables in the output file for this', & + & 'time step than for the previous one',' ') + ELSE + touched_out(fid,:) = .FALSE. + ENDIF + ENDIF +!--- + secsince = itau*deltat(fid) + corner(1) = tstp_out(fid)+1 + edge(1) = 1 +!--- +!-- 3.1 Here we add the values to the time axes +!--- + IF (l_dbg) THEN + WRITE(*,*) 'RESTPUT 3.1 : ',itau,secsince,corner(1),edge(1) + ENDIF +!--- + iret = NF90_PUT_VAR(ncid,tind_varid_out(fid),itau, & + & start=corner(1:1)) + iret = NF90_PUT_VAR(ncid,tax_varid_out(fid),secsince, & + & start=corner(1:1)) +!--- + tstp_out(fid) = tstp_out(fid)+1 + itau_out(fid) = itau + ENDIF +!- +! 4.0 Variable and time step should be present +! now so we can dump variable +!- + ndims = 0 + IF (iim > 0) THEN + ndims = ndims+1 + corner(ndims) = 1 + edge(ndims) = iim + ENDIF + IF (jjm > 0) THEN + ndims = ndims+1 + corner(ndims) = 1 + edge(ndims) = jjm + ENDIF + IF (llm > 0) THEN + ndims = ndims+1 + corner(ndims) = 1 + edge(ndims) = llm + ENDIF + ndims = ndims+1 + corner(ndims) = tstp_out(fid) + edge(ndims) = 1 +!- + iret = NF90_PUT_VAR(ncid,vid,var, & + & start=corner(1:ndims),count=edge(1:ndims)) +!- + IF (iret /= NF90_NOERR) THEN + CALL ipslerr (2,'restput_real',NF90_STRERROR(iret), & + & 'Bug in restput.',& + & 'Please, verify compatibility between get and put commands.') + ENDIF +!- +! 5.0 Note that the variables was treated +!- + touched_out(fid,vnb) = .TRUE. +!--------------------------- +END SUBROUTINE restput_real +!=== +SUBROUTINE restdefv (fid,varname,iim,jjm,llm,write_att) +!--------------------------------------------------------------------- +! This subroutine adds a variable to the output file. +! The attributes are either taken from. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER ::fid + CHARACTER(LEN=*) :: varname + INTEGER :: iim,jjm,llm + LOGICAL :: write_att +!- + INTEGER :: dims(4),ic,xloc,ndim,ncfid + INTEGER :: iret,ax_id + CHARACTER(LEN=3) :: str + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + ncfid = netcdf_id(fid,2) + IF (nbvar_out(fid) >= max_var) THEN + CALL ipslerr (3,'restdefv', & + 'Too many variables for the restcom module', & + 'Please increase the value of max_var',' ') + ENDIF + nbvar_out(fid) = nbvar_out(fid)+1 + varname_out(fid,nbvar_out(fid)) = varname +!- +! 0.0 Put the file in define mode if needed +!- + IF (itau_out(fid) >= 0) THEN + iret = NF90_REDEF(ncfid) + ENDIF +!- +! 1.0 Do we have all dimensions and can we go ahead +!- + IF (l_dbg) THEN + WRITE(*,*) 'restdefv 1.0 :',TRIM(varname),nbvar_out(fid) + ENDIF +!- + ndim = 0 +!- +! 1.1 Work on x +!- + IF (iim > 0) THEN + ndim = ndim+1 + xloc = 0 + DO ic=1,xax_nb(fid) + IF (xax_infs(fid,ic,1) == iim) xloc = ic + ENDDO +!--- + IF (xloc > 0) THEN + dims(ndim) = xax_infs(fid,xloc,2) + ELSE + str='x_'//CHAR(96+xax_nb(fid)) + iret = NF90_DEF_DIM(ncfid,str,iim,ax_id) + xax_nb(fid) = xax_nb(fid)+1 + xax_infs(fid,xax_nb(fid),1) = iim + xax_infs(fid,xax_nb(fid),2) = ax_id + dims(ndim) = ax_id + ENDIF + ENDIF +!- +! 1.2 Work on y +!- + IF (jjm > 0) THEN + ndim = ndim+1 + xloc = 0 + DO ic=1,yax_nb(fid) + IF (yax_infs(fid,ic,1) == jjm) xloc = ic + ENDDO +!--- + IF (xloc > 0) THEN + dims(ndim) = yax_infs(fid,xloc,2) + ELSE + str='y_'//CHAR(96+yax_nb(fid)) + iret = NF90_DEF_DIM(ncfid,str,jjm,ax_id) + yax_nb(fid) = yax_nb(fid)+1 + yax_infs(fid,yax_nb(fid),1) = jjm + yax_infs(fid,yax_nb(fid),2) = ax_id + dims(ndim) = ax_id + ENDIF + ENDIF +!- +! 1.3 Work on z +!- + IF (llm > 0) THEN + ndim = ndim+1 + xloc = 0 + DO ic=1,zax_nb(fid) + IF (zax_infs(fid,ic,1) == llm) xloc = ic + ENDDO +!--- + IF (xloc > 0) THEN + dims(ndim) = zax_infs(fid,xloc,2) + ELSE + str='z_'//CHAR(96+zax_nb(fid)) + iret = NF90_DEF_DIM(ncfid,str,llm,ax_id) + zax_nb(fid) = zax_nb(fid)+1 + zax_infs(fid,zax_nb(fid),1) = llm + zax_infs(fid,zax_nb(fid),2) = ax_id + dims(ndim) = ax_id + ENDIF + ENDIF +!- +! 1.4 Time needs to be added +!- + ndim = ndim+1 + dims(ndim) = tdimid_out(fid) +!- +! 2.0 Declare the variable +!- + IF (l_dbg) THEN + WRITE(*,*) 'restdefv 2.0 :',ndim,' :: ',dims(1:ndim),tdimid_out(fid) + ENDIF +!- + iret = NF90_DEF_VAR(ncfid,varname,NF90_DOUBLE,dims(1:ndim), & + & varid_out(fid,nbvar_out(fid))) + IF (iret /= NF90_NOERR) THEN + CALL ipslerr (3,'restdefv', & + 'Could not define new variable in file', & + NF90_STRERROR(iret),varname) + ENDIF +!- +! 3.0 Add the attributes if requested +!- + IF (write_att) THEN + IF (rest_units /= 'XXXXX') THEN + iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & + & 'units',TRIM(rest_units)) + rest_units = 'XXXXX' + ENDIF +!--- + IF (rest_lname /= 'XXXXX') THEN + iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & + & 'long_name',TRIM(rest_lname)) + rest_lname = 'XXXXX' + ENDIF +!--- + iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), & + & 'missing_value',REAL(missing_val,KIND=4)) +!--- + IF (itau_out(fid) >= 0) THEN + iret = NF90_ENDDEF(ncfid) + ENDIF + ENDIF +!- + IF (l_dbg) THEN + WRITE(*,*) & + & 'restdefv 3.0 : LIST OF VARS ',varname_out(fid,1:nbvar_out(fid)) + ENDIF +!---------------------- +END SUBROUTINE restdefv +!=== +SUBROUTINE rest_atim (l_msg,c_p) +!--------------------------------------------------------------------- +! Called by "c_p", [re]allocate the time axes +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + LOGICAL,INTENT(IN) :: l_msg + CHARACTER(LEN=*),INTENT(IN) :: c_p +!- + INTEGER :: i_err,tszij + INTEGER,ALLOCATABLE :: tmp_index(:,:) + REAL,ALLOCATABLE :: tmp_julian(:,:) +!--------------------------------------------------------------------- +!- +! Allocate the space we need for the time axes +!- + IF (.NOT.ALLOCATED(t_index) .AND. .NOT.ALLOCATED(t_julian)) THEN + IF (l_msg) THEN + WRITE(*,*) TRIM(c_p)//' : Allocate times axes at :', & + & max_file,tax_size_in(nb_fi) + ENDIF +!--- + ALLOCATE(t_index(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_index : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of t_index','', & + & '(you must increase memory)') + ENDIF + t_index (:,:) = 0 +!--- + ALLOCATE(t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_julian : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of max_file,tax_size_in','', & + & '(you must increase memory)') + ENDIF + t_julian (:,:) = 0.0 + ELSE IF ( (SIZE(t_index,DIM=2) < tax_size_in(nb_fi)) & + & .OR.(SIZE(t_julian,DIM=2) < tax_size_in(nb_fi)) ) THEN + IF (l_msg) THEN + WRITE(*,*) TRIM(c_p)//' : Reallocate times axes at :', & + & max_file,tax_size_in(nb_fi) + ENDIF +!--- + ALLOCATE (tmp_index(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of tmp_index : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of tmp_index','', & + & '(you must increase memory)') + ENDIF + tszij = SIZE(t_index,DIM=2) + tmp_index(:,1:tszij) = t_index(:,1:tszij) + DEALLOCATE(t_index) + ALLOCATE (t_index(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_index : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in reallocation of t_index','', & + & '(you must increase memory)') + ENDIF + t_index(:,1:tszij) = tmp_index(:,1:tszij) +!--- + ALLOCATE (tmp_julian(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of tmp_julian : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of tmp_julian','', & + & '(you must increase memory)') + ENDIF + tszij = SIZE(t_julian,DIM=2) + tmp_julian(:,1:tszij) = t_julian(:,1:tszij) + DEALLOCATE(t_julian) + ALLOCATE (t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err) + IF (i_err/=0) THEN + WRITE(*,*) "ERROR IN ALLOCATION of t_julian : ",i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in reallocation of t_julian','', & + & '(you must increase memory)') + ENDIF + t_julian(:,1:tszij) = tmp_julian(:,1:tszij) + ENDIF +!----------------------- +END SUBROUTINE rest_atim +!=== +SUBROUTINE rest_alloc (i_buff,i_qsz,l_msg,c_p) +!--------------------------------------------------------------------- +! Called by "c_p", allocate a temporary buffer +! (buff_tmp[1/2] depending on "i_buff" value) to the size "i_qsz". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: i_buff,i_qsz + LOGICAL,INTENT(IN) :: l_msg + CHARACTER(LEN=*),INTENT(IN) :: c_p +!- + INTEGER :: i_bsz,i_err + LOGICAL :: l_alloc1,l_alloc2 + CHARACTER(LEN=9) :: cbn + CHARACTER(LEN=5) :: c_err +!--------------------------------------------------------------------- + IF (i_buff == 1) THEN + IF (ALLOCATED(buff_tmp1)) THEN + i_bsz = SIZE(buff_tmp1) + ELSE + i_bsz = 0 + ENDIF + l_alloc1 = (.NOT.ALLOCATED(buff_tmp1)) & + & .OR.((ALLOCATED(buff_tmp1)).AND.(i_qsz > i_bsz)) + l_alloc2 = .FALSE. + cbn = 'buff_tmp1' + ELSE IF (i_buff == 2) THEN + IF (ALLOCATED(buff_tmp2)) THEN + i_bsz = SIZE(buff_tmp2) + ELSE + i_bsz = 0 + ENDIF + l_alloc1 = .FALSE. + l_alloc2 = (.NOT.ALLOCATED(buff_tmp2)) & + & .OR.((ALLOCATED(buff_tmp2)).AND.(i_qsz > i_bsz)) + cbn = 'buff_tmp2' + ELSE + CALL ipslerr (3,'rest_alloc', & + & 'Called by '//TRIM(c_p),'with a wrong value of i_buff','') + ENDIF +!- +!- + IF (l_alloc1.OR.l_alloc2) THEN + IF (l_msg) THEN + IF ( (l_alloc1.AND.ALLOCATED(buff_tmp1)) & + & .OR.(l_alloc2.AND.ALLOCATED(buff_tmp2)) ) THEN + WRITE(*,*) TRIM(c_p)//" : re_allocate "//TRIM(cbn)//"=",i_qsz + ELSE + WRITE(*,*) TRIM(c_p)//" : allocate "//TRIM(cbn)//"=",i_qsz + ENDIF + ENDIF + IF (l_alloc1) THEN + IF (ALLOCATED(buff_tmp1)) THEN + DEALLOCATE(buff_tmp1) + ENDIF + ALLOCATE (buff_tmp1(i_qsz),STAT=i_err) + ELSE + IF (ALLOCATED(buff_tmp2)) THEN + DEALLOCATE(buff_tmp2) + ENDIF + ALLOCATE (buff_tmp2(i_qsz),STAT=i_err) + ENDIF + IF (i_err /= 0) THEN + WRITE (UNIT=c_err,FMT='(I5)') i_err + CALL ipslerr (3,TRIM(c_p), & + & 'Problem in allocation of',TRIM(cbn), & + & 'Error : '//TRIM(c_err)//' (you must increase memory)') + ENDIF + ENDIF +!------------------------ +END SUBROUTINE rest_alloc +!=== +SUBROUTINE ioconf_setatt (attname,value) +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: attname,value +!- + CHARACTER(LEN=LEN_TRIM(attname)) :: tmp_str +!--------------------------------------------------------------------- + tmp_str = attname + CALL strlowercase (tmp_str) +!- + SELECT CASE(tmp_str) + CASE('units') + rest_units = value + CASE('long_name') + rest_lname = value + CASE DEFAULT + CALL ipslerr (2,'ioconf_restatt', & + 'The attribute name provided is unknown',attname,' ') + END SELECT +!--------------------------- +END SUBROUTINE ioconf_setatt +!=== +SUBROUTINE ioget_vdim (fid,vname_q,varnbdim_max,varnbdim,vardims) +!--------------------------------------------------------------------- +!- This routine allows the user to get the dimensions +!- of a field in the restart file. +!- This is the file which is read. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid + CHARACTER(LEN=*) :: vname_q + INTEGER,INTENT(IN) :: varnbdim_max + INTEGER,INTENT(OUT) :: varnbdim + INTEGER,DIMENSION(varnbdim_max),INTENT(OUT) :: vardims +!- + INTEGER :: vnb +!--------------------------------------------------------------------- +! Find the index of the variable + CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb) +!- + IF (vnb > 0) THEN + varnbdim = varnbdim_in(fid,vnb) + IF (varnbdim_max < varnbdim) THEN + CALL ipslerr (3,'ioget_vdim', & + 'The provided array for the variable dimensions is too small', & + '','') + ELSE + vardims(1:varnbdim) = vardims_in(fid,vnb,1:varnbdim) + ENDIF + ELSE + varnbdim = 0 + CALL ipslerr (2,'ioget_vdim', & + 'Variable '//TRIM(vname_q)//' not found','','') + ENDIF +!------------------------ +END SUBROUTINE ioget_vdim +!=== +SUBROUTINE ioget_vname (fid,nbvar,varnames) +!--------------------------------------------------------------------- +!- This routine allows the user to extract the list +!- of variables in an opened restart file. +!- This is the file which is read +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: fid + INTEGER,INTENT(OUT) :: nbvar + CHARACTER(LEN=*),INTENT(OUT) :: varnames(:) +!--------------------------------------------------------------------- + nbvar = nbvar_in(fid) +!- + IF (SIZE(varnames) < nbvar) THEN + CALL ipslerr (3,'ioget_vname', & + 'The provided array for the variable names is too small','','') + ELSE + varnames(1:nbvar) = varname_in(fid,1:nbvar) + ENDIF +!------------------------- +END SUBROUTINE ioget_vname +!=== +SUBROUTINE ioconf_expval (new_exp_val) +!--------------------------------------------------------------------- +!- The default value written into the variables which are not +!- in the restart file can only be changed once. +!- This avoids further complications. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL :: new_exp_val +!--------------------------------------------------------------------- + IF (.NOT.lock_valexp) THEN + lock_valexp = .TRUE. + val_exp = new_exp_val + ELSE + CALL ipslerr (2,'ioconf_expval', & + 'The default value for variable' & + //'not available in the restart file ', & + 'has already been locked and can not be changed at this point', & + ' ') + ENDIF +!--------------------------- +END SUBROUTINE ioconf_expval +!=== +SUBROUTINE ioget_expval (get_exp_val) +!--------------------------------------------------------------------- +!- Once the user has extracted the default value, +!- we lock it so that it can not be changed anymore. +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + REAL :: get_exp_val +!--------------------------------------------------------------------- + get_exp_val = val_exp + lock_valexp = .TRUE. +!-------------------------- +END SUBROUTINE ioget_expval +!=== +SUBROUTINE restclo (fid) +!--------------------------------------------------------------------- +!- This subroutine closes one or any opened restart file. +!- +!- INPUT +!- +!- fid : File ID in the restcom system (not the netCDF ID)(optional) +!- +!- OUTPUT +!- +!- NONE +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(in),OPTIONAL :: fid +!- + INTEGER :: iret,ifnc + CHARACTER(LEN=6) :: n_e + CHARACTER(LEN=3) :: n_f + LOGICAL :: l_dbg +!--------------------------------------------------------------------- + CALL ipsldbg (old_status=l_dbg) +!- + IF (PRESENT(fid)) THEN +!--- + IF (l_dbg) THEN + WRITE(*,*) & + 'restclo : Closing specified restart file number :', & + fid,netcdf_id(fid,1:2) + ENDIF +!--- + IF (netcdf_id(fid,1) > 0) THEN + iret = NF90_CLOSE(netcdf_id(fid,1)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(fid,1) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + ENDIF + IF (netcdf_id(fid,1) == netcdf_id(fid,2)) THEN + netcdf_id(fid,2) = -1 + ENDIF + netcdf_id(fid,1) = -1 + ENDIF +!--- + IF (netcdf_id(fid,2) > 0) THEN + iret = NF90_CLOSE(netcdf_id(fid,2)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(fid,2) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + ENDIF + netcdf_id(fid,2) = -1 + ENDIF +!--- + ELSE +!--- + IF (l_dbg) WRITE(*,*) 'restclo : Closing all files' +!--- + DO ifnc=1,nb_fi + IF (netcdf_id(ifnc,1) > 0) THEN + iret = NF90_CLOSE(netcdf_id(ifnc,1)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(ifnc,1) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + ENDIF + IF (netcdf_id(ifnc,1) == netcdf_id(ifnc,2)) THEN + netcdf_id(ifnc,2) = -1 + ENDIF + netcdf_id(ifnc,1) = -1 + ENDIF +!----- + IF (netcdf_id(ifnc,2) > 0) THEN + iret = NF90_CLOSE(netcdf_id(ifnc,2)) + IF (iret /= NF90_NOERR) THEN + WRITE (n_e,'(I6)') iret + WRITE (n_f,'(I3)') netcdf_id(ifnc,2) + CALL ipslerr (2,'restclo', & + "Error "//n_e//" in closing file : "//n_f,'',' ') + END IF + netcdf_id(ifnc,2) = -1 + ENDIF + ENDDO + ENDIF +!--------------------- +END SUBROUTINE restclo +!=== +!----------------- +END MODULE restcom diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/src/stringop.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/src/stringop.f90 new file mode 100644 index 0000000..89be0ee --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/src/stringop.f90 @@ -0,0 +1,185 @@ +MODULE stringop +!- +!$Id: stringop.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +CONTAINS +!= +SUBROUTINE cmpblank (str) +!--------------------------------------------------------------------- +!- Compact blanks +!--------------------------------------------------------------------- + CHARACTER(LEN=*),INTENT(inout) :: str +!- + INTEGER :: lcc,ipb +!--------------------------------------------------------------------- + lcc = LEN_TRIM(str) + ipb = 1 + DO + IF (ipb >= lcc) EXIT + IF (str(ipb:ipb+1) == ' ') THEN + str(ipb+1:) = str(ipb+2:lcc) + lcc = lcc-1 + ELSE + ipb = ipb+1 + ENDIF + ENDDO +!---------------------- +END SUBROUTINE cmpblank +!=== +INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds number of occurences of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!- + INTEGER :: ipos,indx +!--------------------------------------------------------------------- + cntpos = 0 + ipos = 1 + DO + indx = INDEX(c_c(ipos:l_c),c_r(1:l_r)) + IF (indx > 0) THEN + cntpos = cntpos+1 + ipos = ipos+indx+l_r-1 + ELSE + EXIT + ENDIF + ENDDO +!------------------ +END FUNCTION cntpos +!=== +INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r) +!--------------------------------------------------------------------- +!- Finds position of c_r in c_c +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),INTENT(in) :: c_c + INTEGER,INTENT(IN) :: l_c + CHARACTER(LEN=*),INTENT(in) :: c_r + INTEGER,INTENT(IN) :: l_r +!--------------------------------------------------------------------- + findpos = INDEX(c_c(1:l_c),c_r(1:l_r)) + IF (findpos == 0) findpos=-1 +!------------------- +END FUNCTION findpos +!=== +SUBROUTINE find_str (str_tab,str,pos) +!--------------------------------------------------------------------- +!- This subroutine looks for a string in a table +!--------------------------------------------------------------------- +!- INPUT +!- str_tab : Table of strings +!- str : Target we are looking for +!- OUTPUT +!- pos : -1 if str not found, else value in the table +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab + CHARACTER(LEN=*),INTENT(in) :: str + INTEGER,INTENT(out) :: pos +!- + INTEGER :: nb_str,i +!--------------------------------------------------------------------- + pos = -1 + nb_str=SIZE(str_tab) + IF ( nb_str > 0 ) THEN + DO i=1,nb_str + IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN + pos = i + EXIT + ENDIF + ENDDO + ENDIF +!---------------------- +END SUBROUTINE find_str +!=== +SUBROUTINE nocomma (str) +!--------------------------------------------------------------------- +!- Replace commas with blanks +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + IF (str(i:i) == ',') str(i:i) = ' ' + ENDDO +!--------------------- +END SUBROUTINE nocomma +!=== +SUBROUTINE strlowercase (str) +!--------------------------------------------------------------------- +!- Converts a string into lowercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 65).AND.(ic <= 90) ) str(i:i) = ACHAR(ic+32) + ENDDO +!-------------------------- +END SUBROUTINE strlowercase +!=== +SUBROUTINE struppercase (str) +!--------------------------------------------------------------------- +!- Converts a string into uppercase +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + CHARACTER(LEN=*) :: str +!- + INTEGER :: i,ic +!--------------------------------------------------------------------- + DO i=1,LEN_TRIM(str) + ic = IACHAR(str(i:i)) + IF ( (ic >= 97).AND.(ic <= 122) ) str(i:i) = ACHAR(ic-32) + ENDDO +!-------------------------- +END SUBROUTINE struppercase +!=== +SUBROUTINE str_xfw (c_string,c_word,l_ok) +!--------------------------------------------------------------------- +!- Given a character string "c_string", of arbitrary length, +!- returns a logical flag "l_ok" if a word is found in it, +!- the first word "c_word" if found and the new string "c_string" +!- without the first word "c_word" +!--------------------------------------------------------------------- + CHARACTER(LEN=*),INTENT(INOUT) :: c_string + CHARACTER(LEN=*),INTENT(OUT) :: c_word + LOGICAL,INTENT(OUT) :: l_ok +!- + INTEGER :: i_b,i_e +!--------------------------------------------------------------------- + l_ok = (LEN_TRIM(c_string) > 0) + IF (l_ok) THEN + i_b = VERIFY(c_string,' ') + i_e = INDEX(c_string(i_b:),' ') + IF (i_e == 0) THEN + c_word = c_string(i_b:) + c_string = "" + ELSE + c_word = c_string(i_b:i_b+i_e-2) + c_string = ADJUSTL(c_string(i_b+i_e-1:)) + ENDIF + ENDIF +!--------------------- +END SUBROUTINE str_xfw +!=== +!------------------ +END MODULE stringop diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/Fparser.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/tools/Fparser.f90 new file mode 100644 index 0000000..d42469a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/Fparser.f90 @@ -0,0 +1,793 @@ +PROGRAM fparser +!- +!$Id: Fparser.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt + + USE stringop + + IMPLICIT NONE + ! + ! + ! Parses the code to create the Config.in Config.default and Config.help + ! which are used by the tk shell. + ! + ! + INTEGER nbkeymax, nbhelpmax, nbcasemax, nbsourmax, nbelmax + PARAMETER (nbkeymax=100, nbhelpmax=50, nbcasemax=50, nbsourmax=20,nbelmax=nbhelpmax+10) + INTEGER nbfilesmax + PARAMETER (nbfilesmax=150) + + ! + CHARACTER*120 :: configs(nbkeymax,nbelmax) + CHARACTER*120 :: tmp_help, tmp_key, tmp_desc, tmp_def + INTEGER :: keylen(nbkeymax), nbkeys + INTEGER :: key_pos(nbkeymax), help_pos(nbkeymax,2), def_pos(nbkeymax,2) + INTEGER :: des_pos(nbkeymax), IF_pos(nbkeymax) + CHARACTER*6 TYPE_op(nbkeymax) + ! + CHARACTER*120 :: def_out(nbkeymax, nbhelpmax) + INTEGER :: nbdef_out(nbkeymax) + ! + CHARACTER*120 :: tke + ! + CHARACTER*2 :: nbstr + ! + CHARACTER*80 :: files(nbfilesmax), source(nbsourmax), filetmp + CHARACTER*80 :: tmp, main_name + CHARACTER*120 :: keycase(nbcasemax), tmp_CASE + INTEGER :: nbcase, ii, find, nbsource + LOGICAL :: next_source, next_name, last_or + + LOGICAL :: is_main, cont + + CHARACTER*1 :: backslash, simplequote, doublequote + + INTEGER :: ia, iread, iret, IFF, ih, nb_line, iv, id + INTEGER :: ind_space, ind_comma, ind_USE + INTEGER :: nbfiles, nb_key, nb_key_file + ! + INTEGER, EXTERNAL :: iargc, getarg + ! + ! + next_source = .FALSE. + next_name = .FALSE. + is_main = .FALSE. + nbsource = 0 + nbfiles = 0 + main_name = 'IPSL' + ! + backslash = ACHAR(92) + simplequote = ACHAR(39) + doublequote = ACHAR(34) + ! + ! + ! + ! Analyse command line + ! + ! + ! Get the number of arguments, that is the options and the + ! files to be parsed. + ! + ! + + iread = iargc() + ! + DO ia=1,iread + ! + iret = getarg(ia,tmp) + ! + IF (next_source) THEN + + nbsource = nbsource + 1 + IF ( nbsource .GT. nbsourmax) THEN + WRITE(*,*) 'Too many files to source in the arguments.' + WRITE(*,*) 'Increase nbsourmax' + STOP + ELSE + source(nbsource) = tmp(1:LEN_TRIM(tmp)) + ENDIF + next_source = .FALSE. + + ELSE IF (next_name) THEN + main_name = tmp(1:LEN_TRIM(tmp)) + next_name = .FALSE. + + ELSE + ! + IF ( INDEX(tmp,'-m') .GT. 0) THEN + is_main = .TRUE. + ELSE IF ( INDEX(tmp,'-n') .GT. 0) THEN + next_name = .TRUE. + ELSE IF ( INDEX(tmp,'-s') .GT. 0) THEN + next_source = .TRUE. + ELSE IF ( INDEX(tmp,'-h') .GT. 0) THEN + WRITE(*,*) 'USAGE : Fparse [-name NAME] ' + WRITE(*,*) ' [-source file_to_source]' + WRITE(*,*) ' [-main] FORTAN_files' + ELSE + nbfiles = nbfiles + 1 + IF ( nbfiles .GT. nbfilesmax) THEN + WRITE(*,*) 'Too many files to include in & + & the arguments.' + WRITE(*,*) 'Increase nbfilesmax' + STOP + ELSE + files(nbfiles) = tmp(1:LEN_TRIM(tmp)) + ENDIF + ENDIF + + ENDIF + + ENDDO + ! + IF ( nbfiles .LT. 1 ) THEN + WRITE(*,*) 'No files provided' + STOP + ENDIF + ! + ! + ! 1.0 Read files and extract the lines which we need + ! + ! + nb_key = 0 + ! + DO IFF=1,nbfiles + ! + filetmp = files(IFF) + CALL READ_from_file(filetmp, nbkeymax, nbelmax, configs, nb_key, keylen) + ! + ENDDO + ! + ! 2.0 Scan the information we have extracted from the file for the elements we need + ! + ! + CALL analyse_configs(nbkeymax, nb_key, nbelmax, keylen, configs, key_pos, help_pos, def_pos, des_pos, IF_pos, TYPE_op) + ! + ! + ! 3.0 Prepare the default values to put them in an array + ! + ! + DO ia = 1,nb_key + ! + ! 3.1 Go to blank delimited lines + ! + nbdef_out(ia) = 0 + ! + DO ii=def_pos(ia,1), def_pos(ia,2) + ! + tmp_help = configs(ia,ii) + ind_comma = INDEX(tmp_help(1:len_TRIM(tmp_help)),',') + DO WHILE (ind_comma .GT. 0) + tmp_help(ind_comma:ind_comma) = ' ' + ind_comma = INDEX(tmp_help,',') + ENDDO + CALL cmpblank(tmp_help) + configs(ia,ii) = tmp_help + ! + ! 3.2 extract the values + ! + tmp_help = TRIM(ADJUSTL(configs(ia,ii))) + ind_space= INDEX(tmp_help(1:LEN_TRIM(tmp_help)),' ') + ! Get the first one (there is no space in between) + IF ( ind_space .EQ. 0) THEN + nbdef_out(ia) = nbdef_out(ia) + 1 + def_out(ia, nbdef_out(ia)) = tmp_help(1:LEN_TRIM(tmp_help)) + ELSE + ! Get all those which are before spaces + DO WHILE (ind_space .GT. 0) + nbdef_out(ia) = nbdef_out(ia) + 1 + def_out(ia, nbdef_out(ia)) = tmp_help(1:ind_space) + tmp_help = ADJUSTL(tmp_help(ind_space+1:LEN_TRIM(tmp_help))) + ind_space= INDEX(tmp_help(1:LEN_TRIM(tmp_help)),' ') + ENDDO + ! Get the last one which does not have a space behind + IF ( LEN_TRIM(tmp_help) .GT. 0) THEN + nbdef_out(ia) = nbdef_out(ia) + 1 + def_out(ia, nbdef_out(ia)) = tmp_help(1:LEN_TRIM(tmp_help)) + ENDIF + ! + ENDIF + ENDDO + ! + ENDDO + ! + ! + ! + ! 4.0 OPEN Config.in Defaults and Help files + ! + ! + OPEN (16, FILE='Config.in') + OPEN (17, FILE='Config.help') + OPEN (18, FILE='Config.defaults') + ! + ! Some explantation + ! + DO IFF=16,18 + WRITE(IFF,'(1a)') '# ' + WRITE(IFF,'(1a)') '# File created by Fparser, DO NOT EDIT' + WRITE(IFF,'(2a)') '# ', main_name(1:LEN_TRIM(main_name)) + WRITE(IFF,'(1a)') '# ' + WRITE(IFF,'(1a)') '# ' + ENDDO + ! + WRITE(17,'(2a)') '# Format of this file: description<nl>', & + & ' variable<nl>helptext<nl><nl>.' + WRITE(17,'(2a)') '# If the question being documented is of', & + & ' type "choice", we list' + WRITE(17,'(2a)') '# only the first occurring config variable.', & + & ' The help texts' + WRITE(17,'(2a)') '# must not contain empty lines. No variable', & + & ' should occur twice; if it' + WRITE(17,'(2a)') '# does, only the first occurrence will be', & + & ' used by Configure. The lines' + WRITE(17,'(2a)') '# in a help text should be indented two', & + & ' positions. Lines starting with' + WRITE(17,'(2a)') '# "#" are ignored. To be nice to menuconfig,', & + & ' limit your lines to 70' + WRITE(17,'(2a)') '# characters. Use emacs" kfill.el to edit', & + & ' this file or you lose.' + WRITE(17,'(2a)') '#' + ! + IF ( is_main ) THEN + WRITE(16,'(3a)') 'mainmenu_name "Configuration of model ', & + & main_name(1:LEN_TRIM(main_name)), '"' + WRITE(16,'(1a)') '# ' + ENDIF + ! + WRITE(16,'(1a)') 'mainmenu_option next_comment' + WRITE(16,'(3a)') 'comment "', main_name(1:LEN_TRIM(main_name)), '"' + WRITE(16,'(1a)') '# ' + ! + ! 5.0 Loop through the KEYWORDS to prepare the output + ! + DO IFF =1,nb_key + ! + ! Config.in file + ! + + ! + ! Is it a conditional option ? + ! + IF ( IF_pos(IFF) .GE. 0) THEN + tmp_help = configs(IFF,IF_pos(IFF)) + ! + IF ( (index(tmp_help,'||') .LE. 0) .AND. (index(tmp_help,'&&') .LE. 0) ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') 'if [ "$', tmp_help(2:LEN_TRIM(tmp_help)), '" = "n" ]; then' + ELSE + WRITE(16,'(3a)') 'if [ "$', tmp_help(1:LEN_TRIM(tmp_help)), '" = "y" ]; then' + ENDIF + ELSE + ! + last_or = .TRUE. + nbcase = 0 + ! + DO WHILE( INDEX(tmp_help,'||') .GT. 0) + ii = INDEX(tmp_help,'||') + nbcase = nbcase + 1 + if ( nbcase .EQ. 1 ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') 'if [ "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') 'if [ "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ELSE + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-o "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') '-o "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ENDIF + tmp_help = TRIM(ADJUSTL(tmp_help(ii+2:LEN_TRIM(tmp_help)))) + ENDDO + ! + DO WHILE( INDEX(tmp_help,'&&') .GT. 0) + ii = INDEX(tmp_help,'&&') + nbcase = nbcase + 1 + if ( nbcase .EQ. 1 ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') 'if [ "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') 'if [ "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ELSE + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-a "$', tmp_help(2:ii-1), '" = "n" \\' + ELSE + WRITE(16,'(3a)') '-a "$', tmp_help(1:ii-1), '" = "y" \\' + ENDIF + ENDIF + tmp_help = TRIM(ADJUSTL(tmp_help(ii+2:LEN_TRIM(tmp_help)))) + last_or = .FALSE. + ENDDO + ! + IF ( last_or ) THEN + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-o "$', tmp_help(2:LEN_TRIM(tmp_help)), '" = "n" ]; then' + ELSE + WRITE(16,'(3a)') '-o "$', tmp_help(1:LEN_TRIM(tmp_help)), '" = "y" ]; then' + ENDIF + ELSE + IF ( tmp_help(1:1) .EQ. '!') THEN + WRITE(16,'(3a)') '-a "$', tmp_help(2:LEN_TRIM(tmp_help)), '" = "n" ]; then' + ELSE + WRITE(16,'(3a)') '-a "$', tmp_help(1:LEN_TRIM(tmp_help)), '" = "y" ]; then' + ENDIF + ENDIF + ENDIF + WRITE(16,'(1a)') ' ' + ENDIF + ! + ! Extract the information from configs + ! + DO iv = 1,nbdef_out(IFF) + + IF (nbdef_out(IFF) .EQ. 1) THEN + tmp_key = configs(IFF,key_pos(IFF)) + tmp_desc = configs(IFF,des_pos(IFF)) + tmp_def = def_out(IFF,iv) + ELSE + tmp_key = configs(IFF,key_pos(IFF)) + WRITE(nbstr,'(I2.2)') iv + tmp_key = tmp_key(1:LEN_TRIM(tmp_key))//'__'//nbstr + tmp_desc = configs(IFF,des_pos(IFF)) + IF ( iv .EQ. 1) THEN + tmp_desc = tmp_desc(1:LEN_TRIM(tmp_desc))//' (Vector)' + ELSE + tmp_desc = 'Cont... '//tmp_key(1:LEN_TRIM(tmp_key)) + ENDIF + tmp_def = def_out(IFF,iv) + ENDIF + ! + ! + ! + IF (INDEX(TYPE_op(IFF),'bool') .GT. 0) THEN + ! + WRITE(16,'(4a)') 'bool "', tmp_desc(1:LEN_TRIM(tmp_desc)), & + & '" ',tmp_key(1:LEN_TRIM(tmp_key)) + ! + ELSE IF (INDEX(TYPE_op(IFF),'hex') .GT. 0) THEN + ! + WRITE(16,'(6a)') 'hex "', tmp_desc(1:LEN_TRIM(tmp_desc)) & + & ,'" ',tmp_key(1:LEN_TRIM(tmp_key)) & + & ,' ',tmp_def(1:LEN_TRIM(tmp_def)) + ! + ELSE IF (INDEX(TYPE_op(IFF),'choice') .GT. 0) THEN + ! + ! Get number of options + ! + nbcase = 0 + DO WHILE( INDEX(tmp_key,'||') .GT. 0) + ii = INDEX(tmp_key,'||') + nbcase = nbcase + 1 + keycase(nbcase) = tmp_key(1:ii-1) + tmp_key=tmp_key(ii+2:LEN_TRIM(tmp_key)) + ENDDO + nbcase = nbcase + 1 + keycase(nbcase) = tmp_key(1:LEN_TRIM(tmp_key)) + + WRITE(16,'(4a)') "choice '", tmp_desc(1:LEN_TRIM(tmp_desc))," '",backslash + ! + ! List options + ! + tmp_CASE = keycase(1) + WRITE(16,'(5a)') ' "', tmp_CASE(1:LEN_TRIM(tmp_CASE)), " "& + &,tmp_CASE(1:LEN_TRIM(tmp_CASE)), backslash + ! + DO ii=2,nbcase-1 + tmp_CASE = keycase(ii) + WRITE(16,'(5a)') ' ', tmp_CASE(1:LEN_TRIM(tmp_CASE)), ' ',& + & tmp_CASE(1:LEN_TRIM(tmp_CASE)), backslash + ENDDO + ! + tmp_CASE = keycase(nbcase) + WRITE(16,'(6a)') ' ', & + & tmp_CASE(1:LEN_TRIM(tmp_CASE)), & + & ' ', tmp_CASE(1:LEN_TRIM(tmp_CASE)), & + & '" ',tmp_def(1:LEN_TRIM(tmp_def)) + ! + ELSE + WRITE(*,'(2a)') 'Uniplemented operation : ', TYPE_op(IFF) + STOP + ENDIF + ! + ! Config.help file + ! + tmp_key = configs(IFF,key_pos(IFF)) + IF (INDEX(TYPE_op(IFF),'choice') .GT. 0) THEN + ii = INDEX(tmp_key,'||')-1 + ELSE + ii = LEN_TRIM(tmp_key) + ENDIF + + IF ( nbdef_out(IFF) .GT. 1) THEN + WRITE(17,'(1a)') tmp_desc(1:LEN_TRIM(tmp_desc)) + WRITE(nbstr,'(I2.2)') iv + tke = tmp_key(1:ii)//'__'//nbstr + WRITE(17,'(1a)') tke(1:LEN_TRIM(tke)) + WRITE(17,'(1a)') ' (Vector)' + ELSE + WRITE(17,'(1a)') tmp_desc(1:LEN_TRIM(tmp_desc)) + WRITE(17,'(1a)') tmp_key(1:ii) + ENDIF + ! + DO ih=help_pos(IFF,1),help_pos(IFF,2) + tmp_help = configs(IFF,ih) + WRITE(17,'(" ",1a)') tmp_help(1:LEN_TRIM(tmp_help)) + ENDDO + ! + ! Config.default file + ! + IF (INDEX(TYPE_op(IFF),'choice') .GT. 0) THEN + + WRITE(18,'(2a)') tmp_def(1:LEN_TRIM(tmp_def)),'=y' + + ELSE + + WRITE(18,'(3a)') tmp_key(1:LEN_TRIM(tmp_key)),'=', & + & tmp_def(1:LEN_TRIM(tmp_def)) + + ENDIF + ! + ! Add some empty line to all files + ! + WRITE(16,'(1a)') ' ' + WRITE(17,'(1a)') ' ' + WRITE(17,'(1a)') ' ' + ENDDO + ! + ! + ! Close the IF if needed + ! + + IF ( IF_pos(IFF) .GT. 0) THEN + WRITE(16,'(1a)') 'fi' + WRITE(16,'(1a)') ' ' + ENDIF + + ! + ENDDO + ! + WRITE(16,'(1a)') 'endmenu' + WRITE(16,'(1a)') ' ' + IF ( nbsource .GT. 0) THEN + DO ih=1,nbsource + tmp = source(ih) + WRITE(16,'(1a)') ' ' + WRITE(16,'(3a)') 'source ',tmp(1:LEN_TRIM(tmp)), & + & '/Config.in' + ENDDO + ENDIF + ! + ! + CLOSE(16) + CLOSE(17) + CLOSE(18) + ! + ! + ! + STOP + +END PROGRAM fparser +! +! +!========================================================== +! +! +SUBROUTINE READ_from_file(file, nbkeymax, nbelmax, configs, nbitems, itemlen) + ! + USE stringop + ! + IMPLICIT NONE + ! + ! + ! This routine reads the file and adds the config info it finds to the configs array. + ! Thus the nbitems is an imput variable as it can be increased as we go through the files. + ! + ! + CHARACTER*(*) :: file + INTEGER :: nbkeymax, nbelmax + CHARACTER*120 :: configs(nbkeymax, nbelmax) + INTEGER :: nbitems, itemlen(nbkeymax) + ! + INTEGER :: conf_pos, ip + CHARACTER*250 line + LOGICAL :: cont, conf_END + ! + cont = .TRUE. + conf_END = .TRUE. + ! + OPEN (12, file=file) + ! + ! 1.0 Loop over all the lines of a given file to extract all the configuration line + ! + DO WHILE (cont) + READ(12,'(a)',END=9999) line + ! + ! 1.0 A configuration line is detected by the line below. + ! + IF ( INDEX(line,'Config') .EQ. 1 .OR. INDEX(line,'!'//'Config') .GE. 1 ) THEN + ! + IF ( conf_END ) THEN + nbitems = nbitems + 1 + IF ( nbitems .GT. nbkeymax) THEN + WRITE(*,*) 'read_from_file : The number of keys in the input array is too small for this file' + STOP + ENDIF + itemlen(nbitems) = 0 + conf_END = .FALSE. + ENDIF + ! + itemlen(nbitems) = itemlen(nbitems) + 1 + IF ( itemlen(nbitems) .GT. nbelmax ) THEN + WRITE(*,*) 'read_from_file : The number of elements per key in the input array is too small' + STOP + ENDIF + ! + ! The detected line is shaved ! + ! + IF ( INDEX(line,'Config') .EQ. 1) THEN + conf_pos = 7 + ELSE + conf_pos = INDEX(line,'!'//'Config') +7 + ENDIF + line = line(conf_pos:LEN_TRIM(line)) + line = TRIM(ADJUSTL(line)) + CALL cmpblank(line) + ! + configs(nbitems,itemlen(nbitems)) = line + ! + ELSE + ! + ! Look for the end of a configuration structure. + ! It is determined by a call to the getin subroutine + ! + CALL strlowercase(line) + CALL cmpblank(line) + ip = INDEX(line,' (') + DO WHILE (ip .GT. 0) + line = line(1:ip-1)//line(ip+1:LEN_TRIM(line)) + ip = INDEX(line,' (') + ENDDO + IF ( INDEX(line, 'call getin(') .GT. 0 .OR. INDEX(line, 'call setvar(') .GT. 0) THEN + conf_END = .TRUE. + ENDIF + ! + ENDIF + ! + cont = .TRUE. + GOTO 8888 +9999 cont = .FALSE. +8888 CONTINUE + + ENDDO + ! + CLOSE(12) + ! + END SUBROUTINE READ_from_file + ! + !========================================================== + ! + ! + SUBROUTINE analyse_configs(nbkmax, nb_key, nbelmax, keylen, configs, key_pos, help_pos, def_pos, des_pos, IF_pos, TYPE_op) + ! + USE stringop + ! + IMPLICIT NONE + ! + ! + ! This subroutine will localize the KEYWORDS in the configs array + ! and extract all their arguments. For the moment 5 arguments are recognized : + ! KEY : The keyword by which the all is identified + ! HELP : This identifies the help text + ! DEF : The default value of for this KEYWORD + ! DESC : A short description, not more than one line + ! IF : Specifies the other Keyword it depend on. This is a nice features for the menus as it can hide + ! things we do not need + ! + ! The DEF and HELP keywords can be multi line + ! + INTEGER :: nbkmax, nb_key, nbelmax + INTEGER :: keylen(nbkmax) + INTEGER :: key_pos(nbkmax), help_pos(nbkmax,2), def_pos(nbkmax,2), des_pos(nbkmax), IF_pos(nbkmax) + CHARACTER*120 :: configs(nbkmax,nbelmax) + CHARACTER*6 :: TYPE_op(nbkmax) + ! + ! This is the number of arguments we need to find an end for and the total number of arguments we can have. + ! Thus these parameters needs to be updated when the list of arguments to the routine is changed + ! + INTEGER, PARAMETER :: toendlen=2, indexlen=5 + ! + INTEGER :: toend(toendlen), foundend(toendlen), kindex(indexlen) + INTEGER :: ik, il, ieq + CHARACTER*120 :: tmp_str, tmp_str2 + ! + ! + key_pos(1:nb_key)=-1 + help_pos(1:nb_key,1:2)=-1 + def_pos(1:nb_key,1:2)=-1 + des_pos(1:nb_key)=-1 + IF_pos(1:nb_key)=-1 + TYPE_op(1:nb_key)='hex' + ! + DO ik=1,nb_key + ! + ! + DO il=1,keylen(ik) + ! + ieq = INDEX(configs(ik,il),'=') + tmp_str = configs(ik,il) + tmp_str = tmp_str(1:ieq) + CALL struppercase(tmp_str) + ! + ! Decide if this is a reserved name and where it fits + ! + ! At the same time we clean up the configs array + ! + IF ( INDEX(tmp_str,'KEY') .GT. 0) THEN + IF ( key_pos(ik) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a KEYWORD, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + key_pos(ik) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ! + ! Here we have to check that we are not in an 'choice' case + ! + IF ( INDEX(tmp_str2,'||') .GT. 0) THEN + TYPE_op(ik) = 'choice' + ENDIF + ! + ENDIF + ! + IF ( INDEX(tmp_str,'DEF') .GT. 0) THEN + IF ( def_pos(ik,1) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a DEF, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + def_pos(ik,1) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + tmp_str2 = TRIM(ADJUSTL(tmp_str2)) + configs(ik,il) = tmp_str2 + ! + ! Here we can check if we have a boolean operation + ! We also wish to standardise the value of booleans + ! + CALL struppercase(tmp_str2) + IF (INDEX(tmp_str2,'Y') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'T') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'YES') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 3 .OR.& + & INDEX(tmp_str2,'TRUE') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 4 .OR.& + & INDEX(tmp_str2,'.TRUE.') .EQ. 1) THEN + configs(ik,il) = 'y' + TYPE_op(ik) = 'bool' + ENDIF + ! + IF (INDEX(tmp_str2,'N') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'F') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 1 .OR.& + & INDEX(tmp_str2,'NO') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 2 .OR.& + & INDEX(tmp_str2,'FALSE') .EQ. 1 .AND. LEN_TRIM(tmp_str2) .EQ. 5 .OR.& + & INDEX(tmp_str2,'.FALSE.') .EQ. 1) THEN + configs(ik,il) = 'n' + TYPE_op(ik) = 'bool' + ENDIF + ! + ! Here we check if we have a default behavior and put a standard name + ! + IF (INDEX(tmp_str2,'DEF') .EQ. 1 .OR. INDEX(tmp_str2,'NONE') .EQ. 1) THEN + configs(ik,il) = 'default' + ENDIF + ! + ENDIF + ! + IF ( INDEX(tmp_str,'DESC') .GT. 0) THEN + IF ( des_pos(ik) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a DESC, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + des_pos(ik) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ENDIF + ! + IF ( INDEX(tmp_str,'IF') .GT. 0) THEN + IF ( IF_pos(ik) .GT. 0) THEN + WRITE(*,*) 'analyse_config : Already have a IF, check that you have a call to getin' + WRITE(*,*) 'analyse_config : ', configs(ik,il) + STOP + ENDIF + IF_pos(ik) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ENDIF + ! + IF ( INDEX(tmp_str,'HELP') .GT. 0) THEN + help_pos(ik,1) = il + tmp_str2 = configs(ik,il) + tmp_str2 = tmp_str2(ieq+1:LEN_TRIM(tmp_str2)) + configs(ik,il) = TRIM(ADJUSTL(tmp_str2)) + ENDIF + ! + ENDDO + ! + ! Check if we not missing some important informations as for instance + ! + ! THE KEYWORD + ! + IF ( key_pos(ik) .LT. 1) THEN + WRITE(*,*) 'analyse_configs : Could not find a keyword in the following entry :' + DO il=1,keylen(ik) + WRITE(*,'(a70)') configs(ik,il) + ENDDO + STOP + ENDIF + ! + ! THE DEFAULT VALUE + ! + IF ( def_pos(ik,1) .LT. 1) THEN + WRITE(*,*) 'analyse_configs : Could not find a default value in the following entry :' + DO il=1,keylen(ik) + WRITE(*,'(a70)') configs(ik,il) + ENDDO + STOP + ENDIF + ! + ! Get the end of all the multi line arguments + ! + toend(1) = MAX(def_pos(ik,1),1) + toend(2) = MAX(help_pos(ik,1),1) + foundend(:) = keylen(ik) + kindex(1) = MAX(key_pos(ik),1) + kindex(2) = MAX(des_pos(ik),1) + kindex(3) = MAX(def_pos(ik,1),1) + kindex(4) = MAX(IF_pos(ik),1) + kindex(5) = MAX(help_pos(ik,1),1) + CALL find_ends(toendlen, toend, indexlen, kindex, foundend) + def_pos(ik,2) = foundend(1) + help_pos(ik,2) = foundend(2) + ! + ENDDO + ! + END SUBROUTINE analyse_configs + ! + SUBROUTINE find_ends(toendlen, toend, indexlen, kindex, foundend) + ! + IMPLICIT NONE + ! + ! + ! We find the end of the text for all the elements in the key which are multi line + ! This subroutine aims at providing a flexible way to determine this so that other + ! elements in the Keyword can be multi line. For the moment it is only the Help and Ded + ! which are allowed to be multi line. + ! + ! Foundend need to be initialized to the maximum value of the elements + ! + ! + INTEGER :: toendlen, toend(toendlen), indexlen, kindex(indexlen), foundend(toendlen) + ! + INTEGER :: whmin(1), ie, ii + ! + DO ie=1,toendlen + ! + whmin = MINLOC(toend(1:toendlen)) + ! + DO ii=1,indexlen + IF ( kindex(ii) .GT. toend(whmin(1)) .AND. foundend(whmin(1)) .GE. kindex(ii)) THEN + foundend(whmin(1)) = kindex(ii)-1 + toend(whmin(1)) = 100000 + ENDIF + ENDDO + ! + ENDDO + ! + END SUBROUTINE find_ends diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/flio_rbld.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/tools/flio_rbld.f90 new file mode 100644 index 0000000..39aabc8 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/flio_rbld.f90 @@ -0,0 +1,1784 @@ +PROGRAM flio_rbld +! +!$Id: flio_rbld.f90 3680 2012-11-27 14:42:24Z rblod $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!!-------------------------------------------------------------------- +!! PROGRAM flio_rbld +!! +!! PURPOSE : +!! Recombine the files of MPI version of IOIPSL +!! along several dimensions. +!! +!! CALLING SEQUENCE : +!! +!! "flio_rbld" is usually invoked by the script "rebuild" +!! +!! rebuild -h +!! +!! rebuild [-v lev] [-f] -o outfile infile[1] ... infile[n] +!! +!! INPUT for "rebuild" : +!! +!! -h : help +!! -v lev : verbosity level +!! -f : force executing mode +!! -o outfile : name of the recombined file. +!! infiles : names of the files that must be recombined. +!! +!! INPUT for "flio_rbld" : +!! +!! (I) i_v_lev : verbosity level +!! (C) c_force : executing mode (noforce/force) +!! (I) f_nb : total number of files +!! (C) f_nm(:) : names of the files (input_files output_file) +!! +!! +!! ASSOCIATED MODULES : +!! IOIPSL(fliocom) +!! +!! RESTRICTIONS : +!! +!! Cases for character are not coded. +!! +!! Cases for netCDF variables such as array with more +!! than 5 dimensions are not coded. +!! +!! Input files must have the following global attributes : +!! +!! "DOMAIN_number_total" +!! "DOMAIN_number" +!! "DOMAIN_dimensions_ids" +!! "DOMAIN_size_global" +!! "DOMAIN_size_local" +!! "DOMAIN_position_first" +!! "DOMAIN_position_last" +!! "DOMAIN_halo_size_start" +!! "DOMAIN_halo_size_end" +!! "DOMAIN_type" +!! +!! NetCDF files must be smaller than 2 Gb. +!! +!! Character variables should have less than 257 letters +!! +!! EXAMPLE : +!! +!! rebuild -v -o sst.nc sst_[0-9][0-9][0-9][0-9].nc +!! +!! MODIFICATION HISTORY : +!! Sebastien Masson (smasson@jamstec.go.jp) March 2004 +!! Jacques Bellier (Jacques.Bellier@cea.fr) June 2005 +!!-------------------------------------------------------------------- + USE IOIPSL + USE defprec +!- + IMPLICIT NONE +!- +! Character length + INTEGER,PARAMETER :: chlen=256 +!- +! DO loops and test related variables + INTEGER :: i,ia,id,iv,iw,i_i,i_n + INTEGER :: ik,itmin,itmax,it1,it2,it + LOGICAL :: l_force,l_uld +!- +! Input arguments related variables + INTEGER :: i_v_lev + CHARACTER(LEN=15) :: c_force + INTEGER :: f_nb,f_nb_in + CHARACTER(LEN=chlen),DIMENSION(:),ALLOCATABLE :: f_nm +!- +! Domains related variables + INTEGER :: d_n_t,i_ntd + INTEGER,DIMENSION(:),ALLOCATABLE :: dom_att,d_d_i,d_s_g + INTEGER,DIMENSION(:,:),ALLOCATABLE :: d_s_l,d_p_f,d_p_l,d_h_s,d_h_e + LOGICAL :: l_cgd,l_cof,l_col,l_o_f,l_o_m,l_o_l + CHARACTER(LEN=chlen) :: c_d_n +!- +! Model files related variables + LOGICAL :: l_ocf + INTEGER,DIMENSION(:),ALLOCATABLE :: f_a_id + INTEGER :: f_id_i1,f_id_i,f_id_o + INTEGER :: f_d_nb,f_v_nb,f_a_nb,f_d_ul + INTEGER :: v_a_nb,a_type + CHARACTER(LEN=chlen),DIMENSION(:),ALLOCATABLE :: & +& f_d_nm,f_v_nm,f_a_nm,v_a_nm + CHARACTER(LEN=chlen) :: f_u_nm + INTEGER,DIMENSION(:),ALLOCATABLE :: v_d_nb,v_d_ul,v_type + INTEGER,DIMENSION(:,:),ALLOCATABLE :: v_d_i + INTEGER,DIMENSION(:),ALLOCATABLE :: f_d_i,f_d_l + INTEGER :: a_l + INTEGER,DIMENSION(flio_max_var_dims) :: d_i,ib,ie + INTEGER,DIMENSION(:),ALLOCATABLE :: & + & io_i,io_n,ia_sf,io_sf,io_cf,ia_sm,io_sm,io_cm,ia_sl,io_sl,io_cl + LOGICAL :: l_ex + CHARACTER(LEN=chlen) :: c_wn1,c_wn2 +!- +!?INTEGERS of KIND 1 are not supported on all computers +!?INTEGER(KIND=i_1) :: i1_0d +!?INTEGER(KIND=i_1),DIMENSION(:),ALLOCATABLE :: i1_1d +!?INTEGER(KIND=i_1),DIMENSION(:,:),ALLOCATABLE :: i1_2d +!?INTEGER(KIND=i_1),DIMENSION(:,:,:),ALLOCATABLE :: i1_3d +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),ALLOCATABLE :: i1_4d +!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i1_5d + INTEGER(KIND=i_2) :: i2_0d + INTEGER(KIND=i_2),DIMENSION(:),ALLOCATABLE :: i2_1d + INTEGER(KIND=i_2),DIMENSION(:,:),ALLOCATABLE :: i2_2d + INTEGER(KIND=i_2),DIMENSION(:,:,:),ALLOCATABLE :: i2_3d + INTEGER(KIND=i_2),DIMENSION(:,:,:,:),ALLOCATABLE :: i2_4d + INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i2_5d + INTEGER(KIND=i_4) :: i4_0d + INTEGER(KIND=i_4),DIMENSION(:),ALLOCATABLE :: i4_1d + INTEGER(KIND=i_4),DIMENSION(:,:),ALLOCATABLE :: i4_2d + INTEGER(KIND=i_4),DIMENSION(:,:,:),ALLOCATABLE :: i4_3d + INTEGER(KIND=i_4),DIMENSION(:,:,:,:),ALLOCATABLE :: i4_4d + INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),ALLOCATABLE :: i4_5d + REAL(KIND=r_4) :: r4_0d + REAL(KIND=r_4),DIMENSION(:),ALLOCATABLE :: r4_1d + REAL(KIND=r_4),DIMENSION(:,:),ALLOCATABLE :: r4_2d + REAL(KIND=r_4),DIMENSION(:,:,:),ALLOCATABLE :: r4_3d + REAL(KIND=r_4),DIMENSION(:,:,:,:),ALLOCATABLE :: r4_4d + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),ALLOCATABLE :: r4_5d + REAL(KIND=r_8) :: r8_0d + REAL(KIND=r_8),DIMENSION(:),ALLOCATABLE :: r8_1d + REAL(KIND=r_8),DIMENSION(:,:),ALLOCATABLE :: r8_2d + REAL(KIND=r_8),DIMENSION(:,:,:),ALLOCATABLE :: r8_3d + REAL(KIND=r_8),DIMENSION(:,:,:,:),ALLOCATABLE :: r8_4d + REAL(KIND=r_8),DIMENSION(:,:,:,:,:),ALLOCATABLE :: r8_5d +!- +! elapsed and cpu time computation variables + INTEGER :: nb_cc_ini,nb_cc_end,nb_cc_sec,nb_cc_max + REAL :: t_cpu_ini,t_cpu_end +!--------------------------------------------------------------------- +!- +!------------------- +! INPUT arguments +!------------------- +!- +! Retrieve the verbosity level + READ (UNIT=*,FMT=*) i_v_lev +!- +! Retrieve the executing mode + READ (UNIT=*,FMT='(A)') c_force + l_force = (TRIM(c_force) == 'force') +!- +! Retrieve the number of arguments + READ (UNIT=*,FMT=*) f_nb + f_nb_in = f_nb-1 +!- +! Retrieve the file names + ALLOCATE(f_nm(f_nb)) + DO iw=1,f_nb + READ (UNIT=*,FMT='(A)') f_nm(iw) + ENDDO +!- +! Allocate and initialize the array of file access identifiers + ALLOCATE(f_a_id(f_nb_in)); f_a_id(:) = -1; +!- + IF (i_v_lev >= 1) THEN + WRITE (UNIT=*,FMT='("")') + WRITE (UNIT=*,FMT='(" verbosity level : ",I4)') i_v_lev + WRITE (UNIT=*,FMT='(" executing mode : ",A)') TRIM(c_force) + WRITE (UNIT=*,FMT='(" number of args : ",I4)') f_nb + WRITE (UNIT=*,FMT='(" Input files :")') + DO iw=1,f_nb_in + WRITE (*,'(" ",A)') TRIM(f_nm(iw)) + ENDDO + WRITE (UNIT=*,FMT='(" Output file :")') + WRITE (*,'(" ",A)') TRIM(f_nm(f_nb)) +!-- time initializations + CALL system_clock & + & (count=nb_cc_ini,count_rate=nb_cc_sec,count_max=nb_cc_max) + CALL cpu_time (t_cpu_ini) + ENDIF +!- +!--------------------------------------------------- +! Retrieve basic informations from the first file +!--------------------------------------------------- +!- +! Open the first file + CALL flrb_of (1,f_id_i) +!- +! Get the attribute "DOMAIN_number_total" + CALL fliogeta (f_id_i,"?","DOMAIN_number_total",d_n_t) +!- +! Validate the number of input files : +! should be equal to the total number +! of domains used in the simulation + IF (d_n_t /= f_nb_in) THEN + IF (l_force) THEN + iw = 2 + ELSE + iw = 3 + DEALLOCATE(f_nm,f_a_id) + CALL flrb_cf (1,.TRUE.) + ENDIF + CALL ipslerr (iw,"flio_rbld", & + & "The number of input files", & + & "is not equal to the number of DOMAINS"," ") + ENDIF +!- +! Retrieve the basic characteristics of the first input file + CALL flioinqf & + & (f_id_i,nb_dim=f_d_nb,nb_var=f_v_nb,nb_gat=f_a_nb,id_uld=f_d_ul) +!- +! Build the list of the names of the +! dimensions/variables/global_attributes and retrieve +! the unlimited_dimension name from the first input file + ALLOCATE(f_d_nm(f_d_nb),f_v_nm(f_v_nb),f_a_nm(f_a_nb)) + CALL flioinqn (f_id_i,cn_dim=f_d_nm,cn_var=f_v_nm, & + & cn_gat=f_a_nm,cn_uld=f_u_nm) +!- +! Build the list of the dimensions identifiers and lengths + ALLOCATE(f_d_i(f_d_nb),f_d_l(f_d_nb)) + CALL flioinqf (f_id_i,id_dim=f_d_i,ln_dim=f_d_l) +!- +! Close the file + CALL flrb_cf (1,.FALSE.) +!- +! Check if the number of needed files is greater than +! the maximum number of simultaneously opened files. +! In that case, open and close model files for each reading, +! otherwise keep the "flio" identifiers of the opened files. + l_ocf = (f_nb > flio_max_files) +!- +!---------------------------------------------------- +! Retrieve domain informations for each input file +!---------------------------------------------------- +!- + DO iw=1,f_nb_in +!--- + CALL flrb_of (iw,f_id_i) +!--- + IF (iw > 1) THEN + c_wn1 = "DOMAIN_number_total" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),i_ntd) + IF (i_ntd /= d_n_t) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF + ENDIF +!--- + c_wn1 = "DOMAIN_dimensions_ids" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + IF (ANY(dom_att(:) == f_d_ul)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "contains the unlimited dimension") + ENDIF + ALLOCATE (d_d_i(a_l)) + d_d_i(:) = dom_att(:) + ELSEIF (SIZE(dom_att) /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ELSEIF (ANY(dom_att(:) /= d_d_i(:))) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + DEALLOCATE(dom_att) + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_size_global" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_s_g(a_l)) + d_s_g(:)=dom_att(:) + ELSEIF (ANY(dom_att(:) /= d_s_g(:))) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_size_local" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_s_l(a_l,f_nb_in)) + ENDIF + d_s_l(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_position_first" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_p_f(a_l,f_nb_in)) + ENDIF + d_p_f(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_position_last" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_p_l(a_l,f_nb_in)) + ENDIF + d_p_l(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_halo_size_start" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_h_s(a_l,f_nb_in)) + ENDIF + d_h_s(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_halo_size_end" + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + IF (a_l /= SIZE(d_d_i)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "size of the attribute : "//TRIM(c_wn1), & + & "not equal to the size of DOMAIN_dimensions_ids") + ELSE + ALLOCATE(dom_att(a_l)) + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),dom_att) + IF (iw == 1) THEN + ALLOCATE (d_h_e(a_l,f_nb_in)) + ENDIF + d_h_e(:,iw)=dom_att(:) + DEALLOCATE(dom_att) + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + c_wn1 = "DOMAIN_type" + c_wn2 = " " + CALL flioinqa (f_id_i,"?",TRIM(c_wn1),l_ex,a_l=a_l) + IF (l_ex) THEN + CALL fliogeta (f_id_i,"?",TRIM(c_wn1),c_wn2) + CALL strlowercase (c_wn2) + IF (iw == 1) THEN + IF ( (TRIM(c_wn2) == "box") & + & .OR.(TRIM(c_wn2) == "apple") ) THEN + c_d_n = c_wn2 + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "type "//TRIM(c_wn2)//" not (yet) supported") + ENDIF + ELSEIF (TRIM(c_wn2) /= TRIM(c_d_n)) THEN + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1), & + & "not equal to the one of the first file") + ENDIF + ELSE + CALL ipslerr (3,"flio_rbld", & + & "File : "//TRIM(f_nm(iw)), & + & "Attribute : "//TRIM(c_wn1),"not found") + ENDIF +!--- + CALL flrb_cf (iw,l_ocf) +!--- + ENDDO +!- + IF (i_v_lev >= 2) THEN + WRITE (UNIT=*,FMT='("")') + WRITE (*,'(" From the first file : ")') + WRITE (*,'(" Number of dimensions : ",I2)') f_d_nb + WRITE (*,'(" Idents : ",(10(1X,I4),:))') f_d_i(1:f_d_nb) + WRITE (*,'(" Lengths : ",(10(1X,I4),:))') f_d_l(1:f_d_nb) + WRITE (*,'(" Names: ")') + DO i=1,f_d_nb + WRITE (*,'(" """,A,"""")') TRIM(f_d_nm(i)) + ENDDO + IF (f_d_ul > 0) THEN + WRITE (*,'(" Unlimited dimension id : ",I2)') f_d_i(f_d_ul) + ENDIF + WRITE (*,'(" Number of variables : ",I2)') f_v_nb + WRITE (*,'(" Names: ")') + DO i=1,f_v_nb + WRITE (*,'(" """,A,"""")') TRIM(f_v_nm(i)) + ENDDO + WRITE (*,'(" Number of global attributes : ",I2)') f_a_nb + WRITE (*,'(" Names: ")') + DO i=1,f_a_nb + WRITE (*,'(" """,A,"""")') TRIM(f_a_nm(i)) + ENDDO + ENDIF + IF (i_v_lev >= 3) THEN + WRITE (UNIT=*,FMT='("")') + WRITE (*,'(" From input files : ")') + WRITE (*,'(" Total number of DOMAINS : ",I4)') d_n_t + WRITE (*,'(" DOMAIN_dimensions_ids :",(10(1X,I5),:))') d_d_i(:) + WRITE (*,'(" DOMAIN_size_global :",(10(1X,I5),:))') d_s_g(:) + WRITE (*,'(" DOMAIN_type : """,(A),"""")') TRIM(c_d_n) + DO iw=1,f_nb_in + WRITE (*,'(" File : ",A)') TRIM(f_nm(iw)) + WRITE (*,'(" d_s_l :",(10(1X,I5),:))') d_s_l(:,iw) + WRITE (*,'(" d_p_f :",(10(1X,I5),:))') d_p_f(:,iw) + WRITE (*,'(" d_p_l :",(10(1X,I5),:))') d_p_l(:,iw) + WRITE (*,'(" d_h_s :",(10(1X,I5),:))') d_h_s(:,iw) + IF (TRIM(c_d_n) == "apple") THEN + IF (COUNT(d_h_s(:,iw) /= 0) > 1) THEN + CALL ipslerr (3,"flio_rbld", & + & "Beginning offset is not yet supported", & + & "for more than one dimension"," ") + ENDIF + ENDIF + WRITE (*,'(" d_h_e :",(10(1X,I5),:))') d_h_e(:,iw) + IF (TRIM(c_d_n) == "apple") THEN + IF (COUNT(d_h_e(:,iw) /= 0) > 1) THEN + CALL ipslerr (3,"flio_rbld", & + & "Ending offset is not yet supported", & + & "for more than one dimension"," ") + ENDIF + ENDIF + ENDDO + ENDIF +!- +!--------------------------------------- +! Create the dimensionned output file +!--------------------------------------- +!- +! Define the dimensions used in the output file + DO id=1,f_d_nb + DO i=1,SIZE(d_d_i) + IF (f_d_i(id) == d_d_i(i)) THEN + f_d_l(id) = d_s_g(i) + ENDIF + ENDDO + ENDDO +!- + IF (f_d_ul > 0) THEN + i = f_d_l(f_d_ul); f_d_l(f_d_ul) = -1; + ENDIF +!- +! Create the output file + CALL fliocrfd (TRIM(f_nm(f_nb)),f_d_nm,f_d_l,f_id_o,c_f_n=c_wn1) +!- + IF (f_d_ul > 0) THEN + f_d_l(f_d_ul) = i; itmin = 1; itmax = f_d_l(f_d_ul); + ELSE + itmin = 1; itmax = 1; + ENDIF +!- +! open the first input file used to build the output file +!- + CALL flrb_of (1,f_id_i1) +!- +! define the global attributes in the output file +! copy all global attributes except those beginning by "DOMAIN_" +! eventually actualize the "file_name" attribute +!- + DO ia=1,f_a_nb + IF (INDEX(TRIM(f_a_nm(ia)),"DOMAIN_") == 1) CYCLE + IF (TRIM(f_a_nm(ia)) == "file_name") THEN + CALL flioputa (f_id_o,"?",TRIM(f_a_nm(ia)),TRIM(c_wn1)) + ELSE + CALL fliocpya (f_id_i1,"?",TRIM(f_a_nm(ia)),f_id_o,"?") + ENDIF + ENDDO +!- +! define the variables in the output file +!- + ALLOCATE(v_d_nb(f_v_nb)); v_d_nb(:) = 0; + ALLOCATE(v_d_ul(f_v_nb)); v_d_ul(:) = 0; + ALLOCATE(v_type(f_v_nb),v_d_i(flio_max_var_dims,f_v_nb)); + DO iv=1,f_v_nb +!-- get variable informations + CALL flioinqv & + & (f_id_i1,TRIM(f_v_nm(iv)),l_ex,v_t=v_type(iv), & + & nb_dims=v_d_nb(iv),id_dims=d_i,nb_atts=v_a_nb) +!-- define the new variable + IF (v_d_nb(iv) == 0) THEN + CALL fliodefv & + & (f_id_o,TRIM(f_v_nm(iv)),v_t=v_type(iv)) + ELSE + CALL fliodefv & + & (f_id_o,TRIM(f_v_nm(iv)),d_i(1:v_d_nb(iv)),v_t=v_type(iv)) + DO iw=1,v_d_nb(iv) + IF (f_d_ul > 0) THEN + IF (d_i(iw) == f_d_ul) THEN + v_d_ul(iv) = iw + ENDIF + ENDIF + ENDDO + v_d_i(1:v_d_nb(iv),iv) = d_i(1:v_d_nb(iv)) + ENDIF +!-- copy all variable attributes + IF (v_a_nb > 0) THEN + ALLOCATE(v_a_nm(v_a_nb)) + CALL flioinqv (f_id_i1,TRIM(f_v_nm(iv)),l_ex,cn_atts=v_a_nm) + DO ia=1,v_a_nb + CALL fliocpya & + & (f_id_i1,TRIM(f_v_nm(iv)),TRIM(v_a_nm(ia)), & + & f_id_o,TRIM(f_v_nm(iv))) + ENDDO + DEALLOCATE(v_a_nm) + ENDIF + ENDDO +!- +! update valid_min valid_max attributes values +!- + CALL flrb_rg +!- +!------------------------ +! Fill the output file +!------------------------ +!- + DO ik=1,2 + l_uld = (ik /= 1) + IF (l_uld) THEN + it1=itmin; it2=itmax; + ELSE + it1=1; it2=1; + ENDIF + DO it=it1,it2 + DO iv=1,f_v_nb + IF ( (.NOT.l_uld.AND.(v_d_ul(iv) > 0)) & + & .OR.(l_uld.AND.(v_d_ul(iv) <= 0)) ) THEN + CYCLE + ENDIF + IF (i_v_lev >= 3) THEN + WRITE (UNIT=*,FMT='("")') + IF (l_uld) THEN + WRITE (UNIT=*,FMT=*) "time step : ",it + ENDIF + WRITE (UNIT=*,FMT=*) "variable : ",TRIM(f_v_nm(iv)) + WRITE (UNIT=*,FMT=*) "var unlim dim : ",v_d_ul(iv) + ENDIF +!------ do the variable contains dimensions to be recombined ? + l_cgd = .FALSE. + i_n = 1 + DO i=1,SIZE(d_d_i) + l_cgd = ANY(v_d_i(1:v_d_nb(iv),iv) == d_d_i(i)) + l_cgd = l_cgd.AND.ANY(d_s_l(i,1:f_nb_in) /= d_s_g(i)) + IF (l_cgd) THEN + i_n = f_nb_in + EXIT + ENDIF + ENDDO + IF (v_d_nb(iv) > 0) THEN +!-------- Allocate io_i,io_n,ia_sm,io_sm,io_cm + i = v_d_nb(iv) + ALLOCATE(io_i(i),io_n(i),ia_sm(i),io_sm(i),io_cm(i)) +!-------- Default definition of io_i,io_n,io_sm,io_cm + io_i(:) = 1; io_n(:) = f_d_l(v_d_i(1:v_d_nb(iv),iv)); + ia_sm(:) = 1; io_sm(:) = 1; + IF (v_d_ul(iv) > 0) THEN + io_i(v_d_ul(iv))=it + io_n(v_d_ul(iv))=1 + io_sm(v_d_ul(iv))=it + ENDIF + io_cm(:) = io_n(:); +!-------- If needed, allocate offset + l_o_f = .FALSE.; l_o_m = .TRUE.; l_o_l = .FALSE.; + IF (TRIM(c_d_n) == "apple") THEN + ALLOCATE(ia_sf(i),io_sf(i),io_cf(i)) + ALLOCATE(ia_sl(i),io_sl(i),io_cl(i)) + ia_sf(:) = 1; io_sf(:) = 1; io_cf(:) = io_n(:); + ia_sl(:) = 1; io_sl(:) = 1; io_cl(:) = io_n(:); + IF (v_d_ul(iv) > 0) THEN + io_sf(v_d_ul(iv))=it + io_sl(v_d_ul(iv))=it + ENDIF + ENDIF +!-------- Initialize to zero variables data + ! approximate dimension + IF ( it == 1 .AND. l_cgd) THEN + ! Enter I*J I*J is larger thant total number of single files + if ( ((f_d_l(1)/(d_s_l(1,1)-3)) * (f_d_l(2)/(d_s_l(2,1)-3) )) .gt. d_n_t ) then + CALL ZeroFill (f_id_o, f_v_nm(iv), f_d_l, v_d_nb(iv), v_type(iv), v_d_i(1:v_d_nb(iv),iv)) + endif + ENDIF + ENDIF +!------ + DO i_i=1,i_n + IF (l_cgd) THEN +!---------- the variable contains dimensions to be recombined +!----------- +!---------- open each file containing a small piece of data + CALL flrb_of (i_i,f_id_i) +!----------- +!---------- do the variable has offset at first/last block ? + l_cof = .FALSE.; l_col = .FALSE.; + IF (TRIM(c_d_n) == "apple") THEN + L_BF: DO id=1,v_d_nb(iv) + DO i=1,SIZE(d_d_i) + IF (v_d_i(id,iv) == d_d_i(i)) THEN + l_cof = (d_h_s(i,i_i) /= 0) + IF (l_cof) EXIT L_BF + ENDIF + ENDDO + ENDDO L_BF + L_BL: DO id=1,v_d_nb(iv) + DO i=1,SIZE(d_d_i) + IF (v_d_i(id,iv) == d_d_i(i)) THEN + l_col = (d_h_e(i,i_i) /= 0) + IF (l_col) EXIT L_BL + ENDIF + ENDDO + ENDDO L_BL + ENDIF +!---------- if needed, redefine start and count for dimensions + l_o_f = .FALSE.; l_o_m = .TRUE.; l_o_l = .FALSE.; + DO id=1,v_d_nb(iv) + DO i=1,SIZE(d_d_i) + IF (v_d_i(id,iv) == d_d_i(i)) THEN + io_n(id) = d_p_l(i,i_i)-d_p_f(i,i_i)+1 + ia_sm(id) = 1 + io_sm(id) = d_p_f(i,i_i) + io_cm(id) = io_n(id) + IF (TRIM(c_d_n) == "box") THEN + ia_sm(id) = ia_sm(id)+d_h_s(i,i_i) + io_sm(id) = io_sm(id)+d_h_s(i,i_i) + io_cm(id) = io_cm(id)-d_h_s(i,i_i)-d_h_e(i,i_i) + ELSEIF (TRIM(c_d_n) == "apple") THEN + IF (l_cof) THEN + IF (d_h_s(i,i_i) /= 0) THEN + ia_sf(id) = 1+d_h_s(i,i_i) + io_sf(id) = d_p_f(i,i_i)+d_h_s(i,i_i) + io_cf(id) = io_n(id)-d_h_s(i,i_i) + ELSE + io_sf(id) = d_p_f(i,i_i) + io_cf(id) = 1 + ia_sm(id) = ia_sm(id)+1 + io_sm(id) = io_sm(id)+1 + io_cm(id) = io_cm(id)-1 + l_o_f = .TRUE. + ENDIF + ENDIF + IF (l_col) THEN + IF (d_h_e(i,i_i) /= 0) THEN + ia_sl(id) = 1 + io_sl(id) = d_p_f(i,i_i) + io_cl(id) = io_n(id)-d_h_e(i,i_i) + ELSE + io_cm(id) = io_cm(id)-1 + ia_sl(id) = 1+io_n(id)-1 + io_sl(id) = d_p_f(i,i_i)+io_n(id)-1 + io_cl(id) = 1 + l_o_l = .TRUE. + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + ENDDO + l_o_m = ALL(io_cm > 0) + ELSE +!---------- the data can be read/write in one piece + f_id_i = f_id_i1 + ENDIF +!--------- + IF (i_v_lev >= 3) THEN + WRITE (UNIT=*,FMT=*) & + & TRIM(f_nm(i_i))//" - "//TRIM(f_v_nm(iv)) + WRITE (UNIT=*,FMT=*) "io_i : ",io_i(:) + WRITE (UNIT=*,FMT=*) "io_n : ",io_n(:) + WRITE (UNIT=*,FMT=*) "l_o_f : ",l_o_f + IF (l_o_f) THEN + WRITE (UNIT=*,FMT=*) "ia_sf : ",ia_sf(:) + WRITE (UNIT=*,FMT=*) "io_sf : ",io_sf(:) + WRITE (UNIT=*,FMT=*) "io_cf : ",io_cf(:) + ENDIF + WRITE (UNIT=*,FMT=*) "l_o_m : ",l_o_m + IF (l_o_m) THEN + WRITE (UNIT=*,FMT=*) "ia_sm : ",ia_sm(:) + WRITE (UNIT=*,FMT=*) "io_sm : ",io_sm(:) + WRITE (UNIT=*,FMT=*) "io_cm : ",io_cm(:) + ENDIF + WRITE (UNIT=*,FMT=*) "l_o_l : ",l_o_l + IF (l_o_l) THEN + WRITE (UNIT=*,FMT=*) "ia_sl : ",ia_sl(:) + WRITE (UNIT=*,FMT=*) "io_sl : ",io_sl(:) + WRITE (UNIT=*,FMT=*) "io_cl : ",io_cl(:) + ENDIF + ENDIF +!--------- +!-------- Cases according to the type, shape and offsets of the data +!--------- + SELECT CASE (v_type(iv)) +!?INTEGERS of KIND 1 are not supported on all computers +!? CASE (flio_i1) !--- INTEGER 1 +!? SELECT CASE (v_d_nb(iv)) +!? CASE (0) !--- Scalar +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_0d) +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i1_0d) +!? CASE (1) !--- 1d array +!? ALLOCATE(i1_1d(io_n(1))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_1d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_1d(ib(1):ie(1)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_1d(ib(1):ie(1)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_1d(ib(1):ie(1)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_1d) +!? CASE (2) !--- 2d array +!? ALLOCATE(i1_2d(io_n(1),io_n(2))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_2d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_2d(ib(1):ie(1),ib(2):ie(2)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_2d) +!? CASE (3) !--- 3d array +!? ALLOCATE(i1_3d(io_n(1),io_n(2),io_n(3))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_3d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_3d) +!? CASE (4) !--- 4d array +!? ALLOCATE(i1_4d(io_n(1),io_n(2),io_n(3),io_n(4))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_4d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_4d(ib(1):ie(1),ib(2):ie(2), & +!? & ib(3):ie(3),ib(4):ie(4)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_4d(ib(1):ie(1),ib(2):ie(2), & +!? & ib(3):ie(3),ib(4):ie(4)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_4d(ib(1):ie(1),ib(2):ie(2), & +!? & ib(3):ie(3),ib(4):ie(4)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_4d) +!? CASE (5) !--- 5d array +!? ALLOCATE(i1_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) +!? CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i1_5d, & +!? & start=io_i(:),count=io_n(:)) +!? IF (l_o_f) THEN +!? ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & +!? & ib(4):ie(4),ib(5):ie(5)), & +!? & start=io_sf(:),count=io_cf(:)) +!? ENDIF +!? IF (l_o_m) THEN +!? ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & +!? & ib(4):ie(4),ib(5):ie(5)), & +!? & start=io_sm(:),count=io_cm(:)) +!? ENDIF +!? IF (l_o_l) THEN +!? ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; +!? CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & +!? & i1_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & +!? & ib(4):ie(4),ib(5):ie(5)), & +!? & start=io_sl(:),count=io_cl(:)) +!? ENDIF +!? DEALLOCATE(i1_5d) +!? END SELECT +!? CASE (flio_i2) !--- INTEGER 2 + CASE (flio_i1,flio_i2) !--- INTEGER 1/INTEGER 2 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i2_0d) + CASE (1) !--- 1d array + ALLOCATE(i2_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_1d) + CASE (2) !--- 2d array + ALLOCATE(i2_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_2d) + CASE (3) !--- 3d array + ALLOCATE(i2_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_3d) + CASE (4) !--- 4d array + ALLOCATE(i2_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_4d) + CASE (5) !--- 5d array + ALLOCATE(i2_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i2_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i2_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i2_5d) + END SELECT + CASE (flio_i4) !--- INTEGER 4 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),i4_0d) + CASE (1) !--- 1d array + ALLOCATE(i4_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_1d) + CASE (2) !--- 2d array + ALLOCATE(i4_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_2d) + CASE (3) !--- 3d array + ALLOCATE(i4_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_3d) + CASE (4) !--- 4d array + ALLOCATE(i4_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_4d) + CASE (5) !--- 5d array + ALLOCATE(i4_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),i4_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & i4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(i4_5d) + END SELECT + CASE (flio_r4) !--- REAL 4 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),r4_0d) + CASE (1) !--- 1d array + ALLOCATE(r4_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_1d) + CASE (2) !--- 2d array + ALLOCATE(r4_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_2d) + CASE (3) !--- 3d array + ALLOCATE(r4_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_3d) + CASE (4) !--- 4d array + ALLOCATE(r4_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_4d) + CASE (5) !--- 5d array + ALLOCATE(r4_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r4_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r4_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r4_5d) + END SELECT + CASE (flio_r8) !--- REAL 8 + SELECT CASE (v_d_nb(iv)) + CASE (0) !--- Scalar + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_0d) + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)),r8_0d) + CASE (1) !--- 1d array + ALLOCATE(r8_1d(io_n(1))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_1d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:1) = ia_sf(1:1); ie(1:1) = ib(1:1)+io_cf(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_1d(ib(1):ie(1)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:1) = ia_sm(1:1); ie(1:1) = ib(1:1)+io_cm(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_1d(ib(1):ie(1)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:1) = ia_sl(1:1); ie(1:1) = ib(1:1)+io_cl(1:1)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_1d(ib(1):ie(1)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_1d) + CASE (2) !--- 2d array + ALLOCATE(r8_2d(io_n(1),io_n(2))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_2d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:2) = ia_sf(1:2); ie(1:2) = ib(1:2)+io_cf(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:2) = ia_sm(1:2); ie(1:2) = ib(1:2)+io_cm(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:2) = ia_sl(1:2); ie(1:2) = ib(1:2)+io_cl(1:2)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_2d(ib(1):ie(1),ib(2):ie(2)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_2d) + CASE (3) !--- 3d array + ALLOCATE(r8_3d(io_n(1),io_n(2),io_n(3))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_3d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:3) = ia_sf(1:3); ie(1:3) = ib(1:3)+io_cf(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:3) = ia_sm(1:3); ie(1:3) = ib(1:3)+io_cm(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:3) = ia_sl(1:3); ie(1:3) = ib(1:3)+io_cl(1:3)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_3d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_3d) + CASE (4) !--- 4d array + ALLOCATE(r8_4d(io_n(1),io_n(2),io_n(3),io_n(4))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_4d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:4) = ia_sf(1:4); ie(1:4) = ib(1:4)+io_cf(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:4) = ia_sm(1:4); ie(1:4) = ib(1:4)+io_cm(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:4) = ia_sl(1:4); ie(1:4) = ib(1:4)+io_cl(1:4)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_4d(ib(1):ie(1),ib(2):ie(2), & + & ib(3):ie(3),ib(4):ie(4)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_4d) + CASE (5) !--- 5d array + ALLOCATE(r8_5d(io_n(1),io_n(2),io_n(3),io_n(4),io_n(5))) + CALL fliogetv (f_id_i,TRIM(f_v_nm(iv)),r8_5d, & + & start=io_i(:),count=io_n(:)) + IF (l_o_f) THEN + ib(1:5) = ia_sf(1:5); ie(1:5) = ib(1:5)+io_cf(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sf(:),count=io_cf(:)) + ENDIF + IF (l_o_m) THEN + ib(1:5) = ia_sm(1:5); ie(1:5) = ib(1:5)+io_cm(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sm(:),count=io_cm(:)) + ENDIF + IF (l_o_l) THEN + ib(1:5) = ia_sl(1:5); ie(1:5) = ib(1:5)+io_cl(1:5)-1; + CALL flioputv (f_id_o,TRIM(f_v_nm(iv)), & + & r8_5d(ib(1):ie(1),ib(2):ie(2),ib(3):ie(3), & + & ib(4):ie(4),ib(5):ie(5)), & + & start=io_sl(:),count=io_cl(:)) + ENDIF + DEALLOCATE(r8_5d) + END SELECT + END SELECT +!-------- eventually close each file containing a small piece of data + CALL flrb_cf (i_i,l_ocf.AND.l_cgd.AND.(i_i /= 1)) + ENDDO +!------ If needed, deallocate io_* arrays + IF (v_d_nb(iv) > 0) THEN + DEALLOCATE(io_i,io_n,ia_sm,io_sm,io_cm) + IF (TRIM(c_d_n) == "apple") THEN + DEALLOCATE(ia_sf,io_sf,io_cf) + DEALLOCATE(ia_sl,io_sl,io_cl) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +!- +!------------------- +! Ending the work +!------------------- +!- +! Close files + CALL flrb_cf (0,.TRUE.) +!- +! Deallocate + DEALLOCATE(f_nm,f_a_id) + DEALLOCATE(f_d_nm,f_v_nm,f_a_nm) + DEALLOCATE(f_d_i,f_d_l) + DEALLOCATE(v_d_nb,v_d_ul,v_type,v_d_i) + DEALLOCATE(d_d_i,d_s_g) + DEALLOCATE(d_s_l,d_p_f,d_p_l,d_h_s,d_h_e) +!- + IF (i_v_lev >= 1) THEN +!-- elapsed and cpu time computation + CALL cpu_time (t_cpu_end) + CALL system_clock(count=nb_cc_end) + WRITE (UNIT=*,FMT='("")') + WRITE (UNIT=*,fmt='(" elapsed time (s) : ",1PE11.4)') & + & REAL(nb_cc_end-nb_cc_ini)/REAL(nb_cc_sec) + WRITE (UNIT=*,fmt='(" CPU time (s) : ",1PE11.4)') & + & t_cpu_end-t_cpu_ini + ENDIF +!======= +CONTAINS +!======= +SUBROUTINE flrb_of (i_f_n,i_f_i) +!--------------------------------------------------------------------- +! Open the file of number "i_f_n" if necessary, +! and returns its identifier in "i_f_i". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: i_f_n + INTEGER,INTENT(OUT) :: i_f_i +!--------------------------------------------------------------------- + IF (f_a_id(i_f_n) < 0) THEN + CALL flioopfd (TRIM(f_nm(i_f_n)),i_f_i) + f_a_id(i_f_n) = i_f_i + ELSE + i_f_i = f_a_id(i_f_n) + ENDIF +!--------------------- +END SUBROUTINE flrb_of +!=== +SUBROUTINE flrb_cf (i_f_n,l_cf) +!--------------------------------------------------------------------- +! Close the file of number "i_f_n" if "l_cf" is TRUE. +! Close all files if "i_f_n <= 0". +!--------------------------------------------------------------------- + IMPLICIT NONE +!- + INTEGER,INTENT(IN) :: i_f_n + LOGICAL,INTENT(IN) :: l_cf +!--------------------------------------------------------------------- + IF (i_f_n <= 0) THEN + CALL flioclo () + f_a_id(:) = -1 + ELSE + IF (l_cf) THEN + IF (f_a_id(i_f_n) < 0) THEN + CALL ipslerr (2,"flio_rbld", & + & "The file",TRIM(f_nm(i_f_n)),"is already closed") + ELSE + CALL flioclo (f_a_id(i_f_n)) + f_a_id(i_f_n) = -1 + ENDIF + ENDIF + ENDIF +!--------------------- +END SUBROUTINE flrb_cf +!=== +SUBROUTINE flrb_rg +!--------------------------------------------------------------------- +! Update valid_min valid_max attributes values +!--------------------------------------------------------------------- + INTEGER :: k,j + LOGICAL :: l_vmin,l_vmax + INTEGER(KIND=i_4) :: i4_vmin,i4_vmax + REAL(KIND=r_4) :: r4_vmin,r4_vmax + REAL(KIND=r_8) :: r8_vmin,r8_vmax +!--------------------------------------------------------------------- + DO k=1,f_v_nb +!-- get attribute informations + CALL flioinqa & + & (f_id_i1,TRIM(f_v_nm(k)),'valid_min',l_vmin,a_t=a_type) + CALL flioinqa & + & (f_id_i1,TRIM(f_v_nm(k)),'valid_max',l_vmax,a_t=a_type) +!--- + IF (l_vmin.OR.l_vmax) THEN +!---- get values of min/max + SELECT CASE (a_type) + CASE (flio_i1,flio_i2,flio_i4) !--- INTEGER 1/2/4 + DO j=1,f_nb_in + CALL flrb_of (j,f_id_i) + IF (l_vmin) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",i4_0d) + IF (j == 1) THEN + i4_vmin = i4_0d + ELSE + i4_vmin = MIN(i4_vmin,i4_0d) + ENDIF + ENDIF + IF (l_vmax) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",i4_0d) + IF (j == 1) THEN + i4_vmax = i4_0d + ELSE + i4_vmax = MAX(i4_vmax,i4_0d) + ENDIF + ENDIF + CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) + ENDDO + IF (l_vmin) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",i4_vmin) + ENDIF + IF (l_vmax) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",i4_vmax) + ENDIF + CASE (flio_r4) !--- REAL 4 + DO j=1,f_nb_in + CALL flrb_of (j,f_id_i) + IF (l_vmin) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",r4_0d) + IF (j == 1) THEN + r4_vmin = r4_0d + ELSE + r4_vmin = MIN(r4_vmin,r4_0d) + ENDIF + ENDIF + IF (l_vmax) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",r4_0d) + IF (j == 1) THEN + r4_vmax = r4_0d + ELSE + r4_vmax = MAX(r4_vmax,r4_0d) + ENDIF + ENDIF + CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) + ENDDO + IF (l_vmin) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",r4_vmin) + ENDIF + IF (l_vmax) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",r4_vmax) + ENDIF + CASE (flio_r8) !--- REAL 8 + DO j=1,f_nb_in + CALL flrb_of (j,f_id_i) + IF (l_vmin) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_min",r8_0d) + IF (j == 1) THEN + r8_vmin = r8_0d + ELSE + r8_vmin = MIN(r8_vmin,r8_0d) + ENDIF + ENDIF + IF (l_vmax) THEN + CALL fliogeta(f_id_i,TRIM(f_v_nm(k)),"valid_max",r8_0d) + IF (j == 1) THEN + r8_vmax = r8_0d + ELSE + r8_vmax = MAX(r8_vmax,r8_0d) + ENDIF + ENDIF + CALL flrb_cf (j,l_ocf.AND.(f_id_i /= f_id_i1)) + ENDDO + IF (l_vmin) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_min",r8_vmin) + ENDIF + IF (l_vmax) THEN + CALL flioputa (f_id_o,TRIM(f_v_nm(k)),"valid_max",r8_vmax) + ENDIF + END SELECT + ENDIF + ENDDO +!--------------------- +END SUBROUTINE flrb_rg +!=== +SUBROUTINE ZeroFill(f_id_o,f_v_nm,f_d_l,v_d_nb,v_type,v_d_i) + + IMPLICIT NONE +! Character length + INTEGER,PARAMETER :: chlen=256 + + INTEGER :: v_d_nb, v_type ! variable # of dims, variable type, var Unlim dimension + INTEGER :: f_id_o ! Output file ID + INTEGER,DIMENSION(:) :: f_d_l, v_d_i ! Global dimensions, variable dimensio ID + CHARACTER(LEN=chlen) :: f_v_nm ! Variable name + INTEGER,DIMENSION(:),ALLOCATABLE :: dims + + INTEGER(KIND=i_2) :: i2_0d + INTEGER(KIND=i_2), ALLOCATABLE :: i2_1d(:), i2_2d(:,:), i2_3d(:,:,:), i2_4d(:,:,:,:), i2_5d(:,:,:,:,:) + INTEGER(KIND=i_4) :: i4_0d + INTEGER(KIND=i_4), ALLOCATABLE :: i4_1d(:), i4_2d(:,:), i4_3d(:,:,:), i4_4d(:,:,:,:), i4_5d(:,:,:,:,:) + REAL(KIND=r_4) :: r4_0d + REAL(KIND=r_4), ALLOCATABLE :: r4_1d(:), r4_2d(:,:), r4_3d(:,:,:), r4_4d(:,:,:,:), r4_5d(:,:,:,:,:) + REAL(KIND=r_8) :: r8_0d + REAL(KIND=r_8), ALLOCATABLE :: r8_1d(:), r8_2d(:,:), r8_3d(:,:,:), r8_4d(:,:,:,:), r8_5d(:,:,:,:,:) + + ! write(*,*) ' Into my sub... TOM' + ! write(*,*) f_id_o, TRIM(f_v_nm), v_d_nb , v_type + write(*,*) 'Variable: ',TRIM(f_v_nm), ' intiliazed to zero' + write(*,*) + + ! define variable dimension + ALLOCATE(dims(v_d_nb)) + dims=f_d_l(v_d_i) + SELECT CASE(v_type) + ! INTEGER 1 and 2 + CASE (flio_i1,flio_i2) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(i2_1d(dims(1))) + i2_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_1d) + DEALLOCATE(i2_1d) + CASE(2) + ALLOCATE(i2_2d(dims(1),dims(2))) + i2_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_2d) + DEALLOCATE(i2_2d) + CASE(3) + ALLOCATE(i2_3d(dims(1),dims(2),dims(3))) + i2_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_3d) + DEALLOCATE(i2_3d) + CASE(4) + ALLOCATE(i2_4d(dims(1),dims(2),dims(3),dims(4))) + i2_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_4d) + DEALLOCATE(i2_4d) + CASE(5) + ALLOCATE(i2_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + i2_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i2_5d) + DEALLOCATE(i2_5d) + END SELECT + ! INTEGER 4 + CASE (flio_i4) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(i4_1d(dims(1))) + i4_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_1d) + DEALLOCATE(i4_1d) + CASE(2) + ALLOCATE(i4_2d(dims(1),dims(2))) + i4_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_2d) + DEALLOCATE(i4_2d) + CASE(3) + ALLOCATE(i4_3d(dims(1),dims(2),dims(3))) + i4_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_3d) + DEALLOCATE(i4_3d) + CASE(4) + ALLOCATE(i4_4d(dims(1),dims(2),dims(3),dims(4))) + i4_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_4d) + DEALLOCATE(i4_4d) + CASE(5) + ALLOCATE(i4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + i4_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),i4_5d) + DEALLOCATE(i4_5d) + END SELECT + ! FLOAT 4 + CASE (flio_r4) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(r4_1d(dims(1))) + r4_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_1d) + DEALLOCATE(r4_1d) + CASE(2) + ALLOCATE(r4_2d(dims(1),dims(2))) + r4_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_2d) + DEALLOCATE(r4_2d) + CASE(3) + ALLOCATE(r4_3d(dims(1),dims(2),dims(3))) + r4_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_3d) + DEALLOCATE(r4_3d) + CASE(4) + ALLOCATE(r4_4d(dims(1),dims(2),dims(3),dims(4))) + r4_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_4d) + DEALLOCATE(r4_4d) + CASE(5) + ALLOCATE(r4_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + r4_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r4_5d) + DEALLOCATE(r4_5d) + END SELECT + ! FLOAT 8 + CASE (flio_r8) + SELECT CASE (v_d_nb) + CASE(1) + ALLOCATE(r8_1d(dims(1))) + r8_1d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_1d) + DEALLOCATE(r8_1d) + CASE(2) + ALLOCATE(r8_2d(dims(1),dims(2))) + r8_2d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_2d) + DEALLOCATE(r8_2d) + CASE(3) + ALLOCATE(r8_3d(dims(1),dims(2),dims(3))) + r8_3d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_3d) + DEALLOCATE(r8_3d) + CASE(4) + ALLOCATE(r8_4d(dims(1),dims(2),dims(3),dims(4))) + r8_4d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_4d) + DEALLOCATE(r8_4d) + CASE(5) + ALLOCATE(r8_5d(dims(1),dims(2),dims(3),dims(4),dims(5))) + r8_5d=0 + CALL flioputv (f_id_o,TRIM(f_v_nm),r8_5d) + DEALLOCATE(r8_5d) + END SELECT + END SELECT + + DEALLOCATE (dims) + +END SUBROUTINE +!=== +!-------------------- +END PROGRAM flio_rbld diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/ncregular.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/tools/ncregular.f90 new file mode 100644 index 0000000..1f53f95 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/ncregular.f90 @@ -0,0 +1,328 @@ +PROGRAM ncregular +! +!$Id: ncregular.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!--------------------------------------------------------------------- +!- This code replaces a 2D surface grid by vectors. +!- Obviously it only works if you have a regular grid. +!- +!- Jan Polcher (polcher@lmd.jussieu.fr) +!- Jacques Bellier (jacques.bellier@cea.fr) +!--------------------------------------------------------------------- + USE netcdf +!- + IMPLICIT NONE +!- + INTEGER :: iread, if, in, iv, sz + INTEGER :: ier, nb_files, iret, ndims, nvars, nb_glat + INTEGER :: lon_dim_id, lat_dim_id + INTEGER :: lon_len, lat_len, lon_id, lat_id + INTEGER :: nav_lon_id, nav_lat_id + INTEGER :: alloc_stat_lon, alloc_stat_lat +!- + INTEGER,ALLOCATABLE :: file_id(:), tax_id(:) + CHARACTER(LEN=80),ALLOCATABLE :: names(:) + CHARACTER(LEN=80) :: dim_name + CHARACTER(LEN=80) :: varname + CHARACTER(LEN=20) :: xname, yname, lonname, latname + LOGICAL :: check, regular +!- + REAL,ALLOCATABLE :: lon(:), lat(:), lon2(:), lat2(:) + REAL,ALLOCATABLE :: del_lon(:), del_lat(:) +!- + INTEGER iargc, getarg + EXTERNAL iargc, getarg +!--------------------------------------------------------------------- + alloc_stat_lon = 0 + alloc_stat_lat = 0 +!- + iread = iargc() +!- + ALLOCATE (names(iread),stat=ier) + IF (ier /= 0) THEN + WRITE (*,*) ' Could not allocate names of size ', iread + STOP 'nctax' + ENDIF +!- + CALL nct_getarg (iread, nb_files, names, check, & + & xname, yname, lonname, latname) +!- +! Allocate space +!- + ALLOCATE (file_id(nb_files),stat=ier) + IF (ier /= 0) THEN + WRITE (*,*) ' Could not allocate file_id of size ', nb_files + STOP 'nctax' + ENDIF +!- + ALLOCATE (tax_id(nb_files),stat=ier) + IF (ier /= 0) THEN + WRITE (*,*) ' Could not allocate tax_id of size ', nb_files + STOP 'nctax' + ENDIF +!- + DO if=1,nb_files +!--- + IF (check) THEN + WRITE(*,*) 'ncregular : ', if, names(if) + ENDIF +!--- + iret = NF90_OPEN (names(if),NF90_WRITE,file_id(if)) + iret = NF90_INQUIRE (file_id(if),ndims,nvars,nb_glat,tax_id(if)) +!--- +!-- Get the IDs of the variables +!--- + lon_len = -9999 + lat_len = -9999 + DO in=1,ndims +!----- + iret = NF90_INQUIRE_DIMENSION (file_id(if), in, dim_name, sz) +!----- + IF ( (LEN_TRIM(dim_name) == 1) & + & .AND.(INDEX(dim_name,TRIM(xname)) == 1) ) THEN + lon_dim_id = in + lon_len = sz + ENDIF +!----- + IF ( (LEN_TRIM(dim_name) == 1) & + & .AND.(INDEX(dim_name,TRIM(yname)) == 1) ) THEN + lat_dim_id = in + lat_len = sz + ENDIF +!----- + ENDDO +!--- + IF ( (lon_len == -9999).OR.(lat_len == -9999) ) THEN + WRITE(*,*) 'ncregular : The specified dimensions were not' + WRITE(*,*) 'found in file : ',names(if) + iret = NF90_CLOSE (file_id(if)) + STOP + ENDIF +!--- + IF (check) THEN + WRITE(*,*) 'ncregular : lon_dim_id, lon_len',lon_dim_id,lon_len + WRITE(*,*) 'ncregular : lat_dim_id, lat_len',lat_dim_id,lat_len + ENDIF +!--- +!-- Look for the right variables +!--- + nav_lon_id = -9999 + nav_lat_id = -9999 + DO iv=1,nvars + iret = NF90_INQUIRE_VARIABLE (file_id(if),iv,name=varname) + IF (INDEX(varname,TRIM(lonname)) > 0) THEN + nav_lon_id = iv + ENDIF + IF (INDEX(varname,TRIM(latname)) > 0) THEN + nav_lat_id = iv + ENDIF + ENDDO +!--- + IF ( (nav_lon_id == -9999).OR.(nav_lat_id == -9999) ) THEN + WRITE(*,*) 'ncregular : The specified coordinate fields' + WRITE(*,*) 'were not found in file : ',names(if) + iret = NF90_CLOSE (file_id(if)) + STOP + ENDIF +!--- + IF (check) THEN + WRITE(*,*) 'ncregular : nav_lon_id :', nav_lon_id + WRITE(*,*) 'ncregular : nav_lat_id :', nav_lat_id + ENDIF +!--- +!-- Read variables from file and check if regular +!--- +!-- Do we have the variable to read the +!--- + IF ( alloc_stat_lon < lon_len) THEN + IF ( alloc_stat_lon > 0) THEN + deallocate(lon) + deallocate(lon2) + deallocate(del_lon) + ENDIF + allocate(lon(lon_len)) + allocate(lon2(lon_len)) + allocate(del_lon(lon_len)) + alloc_stat_lon = lon_len + ENDIF +!--- + IF ( alloc_stat_lat < lat_len) THEN + IF ( alloc_stat_lat > 0) THEN + deallocate(lat) + deallocate(lat2) + deallocate(del_lat) + ENDIF + allocate(lat(lat_len)) + allocate(lat2(lat_len)) + allocate(del_lat(lat_len)) + alloc_stat_lat = lat_len + ENDIF +!--- +!-- Read data +!--- + iret = NF90_GET_VAR (file_id(if),nav_lon_id,lon, & + & start=(/1,1/),count=(/lon_len,1/),stride=(/1,1/)) + iret = NF90_GET_VAR (file_id(if),nav_lon_id,lon2, & + & start=(/1,int(lat_len/2)/),count=(/lon_len,1/),stride=(/1,1/)) + del_lon = lon-lon2 +!- + iret = NF90_GET_VAR (file_id(if),nav_lat_id,lat, & + & start=(/1,1/),count=(/1,lat_len/),stride=(/lon_len,1/)) + iret = NF90_GET_VAR (file_id(if),nav_lat_id,lat2, & + & start=(/int(lon_len/2),1/),count=(/1,lat_len/),stride=(/lon_len,1/)) + del_lat = lat-lat2 +!- + regular = ( (MAXVAL(del_lon) < 0.001) & + & .OR.(MAXVAL(del_lat) < 0.001) ) +!--- +!-- Create the new variables +!--- + IF (regular) THEN + IF (check) THEN + WRITE(*,*) 'Regular case' + ENDIF + iret = NF90_REDEF (file_id(if)) + iret = NF90_RENAME_DIM (file_id(if), lon_dim_id, 'lon') + iret = NF90_RENAME_DIM (file_id(if), lat_dim_id, 'lat') + IF (check) THEN + WRITE(*,*) 'Dimensions renamed' + ENDIF + iret = NF90_DEF_VAR (file_id(if), 'lon', NF90_FLOAT, & + & lon_dim_id, lon_id) + iret = NF90_DEF_VAR (file_id(if), 'lat', NF90_FLOAT, & + & lat_dim_id, lat_id) + IF (check) THEN + WRITE(*,*) 'New variables defined' + ENDIF +!----- +!---- Copy attributes +!----- + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'units', & + & file_id(if),lon_id) + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'title', & + & file_id(if),lon_id) + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'valid_max', & + & file_id(if),lon_id) + iret = NF90_COPY_ATT (file_id(if),nav_lon_id,'valid_min', & + & file_id(if),lon_id) +!----- + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'units', & + & file_id(if),lat_id) + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'title', & + & file_id(if),lat_id) + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'valid_max', & + & file_id(if),lat_id) + iret = NF90_COPY_ATT (file_id(if),nav_lat_id,'valid_min', & + & file_id(if),lat_id) +!----- +!---- Go into write mode +!----- + iret = NF90_ENDDEF (file_id(if)) +!----- +!---- Write data +!----- + iret = NF90_PUT_VAR (file_id(if),lon_id,lon(1:lon_len)) + iret = NF90_PUT_VAR (file_id(if),lat_id,lat(1:lat_len)) +!- + iret = NF90_CLOSE (file_id(if)) + ELSE + WRITE(*,*) 'ncregular : Your grid is not regular' + WRITE(*,*) names(if), 'remains unchanged' + iret = NF90_CLOSE (file_id(if)) + ENDIF +!- + ENDDO +!-------------------- +END PROGRAM ncregular +!- +!=== +!- +SUBROUTINE nct_getarg (argx, nb_files, names, check, & + & xname, yname, lonname, latname) +!--------------------------------------------------------------------- +!- Read the arguments of nctax. +!--------------------------------------------------------------------- + INTEGER,INTENT(in) :: argx + INTEGER, INTENT(out) :: nb_files + CHARACTER(LEN=80),INTENT(out) :: names(argx) + CHARACTER(LEN=20) :: xname, yname, lonname, latname +!- + CHARACTER(LEN=80) :: tmp, tmp_arg + LOGICAL :: check +!--------------------------------------------------------------------- + check = .FALSE. +!- +! Get the number of arguments +!- + nb_files = 0 +!- + xname = 'x' + yname = 'y' + lonname = 'nav_lon' + latname = 'nav_lat' +!- +! Go through the arguments and analyse them one by one +!- + IF (check) WRITE(*,*) 'Start going through the arguments' +!- + IF (argx == 0) THEN + WRITE(*,*) 'To get usage : nctax -h ' + STOP + ENDIF +!- + iread = 1 + DO WHILE (iread <= argx) + iret = getarg(iread,tmp) + IF (check) WRITE(*,*) ' iread, tmp :', iread, tmp + SELECTCASE(tmp) + CASE('-d') + WRITE(*,*) 'DEBUG MODE SELECTED' + check = .TRUE. + iread = iread+1 + CASE('-h') + WRITE(*,*) 'Usage : nregular [options] file1 [file2 ...]' + WRITE(*,*) ' -d : Verbose mode' + WRITE(*,*) ' -h : This output' + STOP + CASE('-dim_lon') + iread = iread+1 + iret = getarg(iread,tmp_arg) + xname = TRIM(tmp_arg) + iread = iread+1 + CASE('-dim_lat') + iread = iread+1 + iret = getarg(iread,tmp_arg) + yname = TRIM(tmp_arg) + iread = iread+1 + CASE('-coo_lon') + iread = iread+1 + iret = getarg(iread,tmp_arg) + lonname = TRIM(tmp_arg) + iread = iread+1 + CASE('-coo_lat') + iread = iread+1 + iret = getarg(iread,tmp_arg) + latname = TRIM(tmp_arg) + iread = iread+1 + CASE DEFAULT + IF (check) WRITE(*,*) 'nct_getarg : CASE default' + IF (INDEX(tmp,'-') /= 1) THEN + nb_files = nb_files+1 + names(nb_files) = tmp + iread = iread+1 + ELSE + WRITE(*,*) "WARNING Unknown option ",tmp + WRITE(*,*) "For ore information : nctax -h" + ENDIF + END SELECT + ENDDO +!- + IF (check) THEN + WRITE(*,*) ' nct_getarg : output >> ' + WRITE(*,*) '>> nb_files : ', nb_files + WRITE(*,*) '>> names :', (names(ii), ii=1,nb_files) + ENDIF +!------------------------ +END SUBROUTINE nct_getarg diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/ncunderflow.f90 b/NEMO_4.0.4_surge/ext/IOIPSL/tools/ncunderflow.f90 new file mode 100644 index 0000000..3d4655e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/ncunderflow.f90 @@ -0,0 +1,393 @@ +MODULE declare +! -*- Mode: f90 -*- +!$Id: ncunderflow.f90 2281 2010-10-15 14:21:13Z smasson $ +!- +! This software is governed by the CeCILL license +! See IOIPSL/IOIPSL_License_CeCILL.txt +!- +! f90 -L/usr/local/lib -lnetcdf -align dcommons -g +! -ladebug -check format -check bounds +! -check output_conversion -fpe1 +! -I/usr/local/include -free -arch host -tune host +! -warn declarations -warn argument_checking +! ncunderflow.f -o ncunderflow +! +! ifc -FR -cl,ncunderflow.pcl -o ncunderflow ncunderflow.f +! -L/usr/local/install/netcdf/lib/libnetcdf.a -lPEPCF90 +! + IMPLICIT NONE + INTEGER, PARAMETER :: r4 = 4, r8 = 8, i4 = 4, i8 = 8 + INTEGER, PARAMETER :: il = KIND(1) + LOGICAL :: ldebug = .FALSE. + INTEGER (kind = il) :: nout = 0, nerr = 0 ! Standard output, standard error + CHARACTER (LEN=4), PARAMETER :: cerror = 'VOID' +END MODULE declare +!! +MODULE mod_nfdiag +CONTAINS + SUBROUTINE nfdiag ( kios, clmess, lcd) + !! + !! Imprime un message d'erreur NetCDF + !! + USE declare + IMPLICIT NONE + INCLUDE 'netcdf.inc' + !! + INTEGER (kind=i4), INTENT (in) :: kios + CHARACTER (len = *), INTENT (in) :: clmess + LOGICAL, INTENT (in), OPTIONAL :: lcd + CHARACTER (len = 80) :: clt + LOGICAL :: ld + !! + IF ( PRESENT ( lcd)) THEN + ld = lcd + ELSE + ld = ldebug + ENDIF + !! + clt = TRIM ( NF_STRERROR ( kios) ) + !! + IF ( ld ) THEN + IF ( kios == NF_NOERR ) THEN + WRITE ( unit = nout, fmt = * ) "OK : ", TRIM (clmess) + ELSE + WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios + IF ( .NOT. ld ) STOP + END IF + ELSE + IF ( kios /= NF_NOERR ) THEN + WRITE ( unit = nout, fmt = * ) "ERROR : ", TRIM (clmess), " : ", TRIM ( clt), " : ", kios + STOP + END IF + ENDIF + !! + RETURN + !! + END SUBROUTINE nfdiag + !! +END MODULE mod_nfdiag + +MODULE mod_lec +CONTAINS + !! + SUBROUTINE lec (chaine, cval, c_c) + !! + USE declare + IMPLICIT NONE + !! + CHARACTER (len = *), INTENT ( inout) :: chaine + CHARACTER (len = *), INTENT ( inout) :: cval + CHARACTER (len=*), OPTIONAL :: c_c + INTEGER (kind = il) :: ji, ji1, ji2, ji3, jl, jb + INTEGER (kind = i4) :: index + !! + !! Read character string up to ':' or ',', or in c_c if present + !! Returns the real before the character (xerror if not available) + !! Reduce the string + !! + jl = LEN (chaine) ; jb = LEN_TRIM (chaine) + IF ( ldebug) WRITE ( nout, *) 'Lec : jl, jb ', jl, jb + IF ( jb == 0 ) THEN + cval = cerror + ELSE + ji1 = INDEX (chaine, ':') ; ji2 = INDEX (chaine, ',') + IF ( PRESENT (c_c)) THEN + ji3 = INDEX (chaine, c_c) ; ji = MAX (ji1, ji2, ji3) + ELSE + ji = MAX (ji1, ji2) + ENDIF + IF ( ji == 0 ) THEN + READ ( chaine (1:jb) , fmt = * ) cval + chaine (1:jl-jb) = chaine (jb+1:jl) + ELSE IF ( ji == 1 ) THEN + cval = cerror + chaine (1:jl-1) = chaine (2:jl) + ELSE + cval = chaine (1:ji-1) + chaine (1:jl-ji) = chaine (ji+1:jl ) + END IF + END IF + !! + END SUBROUTINE lec +END MODULE mod_lec + +PROGRAM ncunderflow + + ! Ce programme ouvre un fichier de donnees au format netcdf + ! et met a zero toutes les valeurs trop petites pour etre + ! representees par un reel sur 4 octets au format IEEE + ! + ! Revision 2.0 2004/04/05 14:47:50 adm + ! JB+MAF+AC: switch to IOIPSL 2.0 (1) + ! + ! Revision 1.1 2003/04/09 15:21:56 adm + ! add ncunderflow in IOIPSL + ! and modify AA_make to take it into account + ! SD + MAF + ! + ! Revision 1.1 2001/02/07 14:36:07 jypeter + ! J-Y Peterschmitt / LMCE / 07/02/2001 + ! Initial revision + ! + USE declare + USE mod_nfdiag + USE mod_lec + IMPLICIT NONE + + INCLUDE 'netcdf.inc' + + INTEGER (kind=il), EXTERNAL :: iargc + + ! Nombre maximal de dimensions : 6 + + INTEGER (kind=il), PARAMETER :: jpmaxdim = 6, jpmaxvar = 1024 + + CHARACTER (len = 128) :: clnomprog, clnomfic + CHARACTER (len = 1024) :: clistvar, clecline + CHARACTER (len = 128), DIMENSION(jpmaxdim) :: clnomdim + CHARACTER (len = 128), DIMENSION(jpmaxvar) :: clvarcmd, clvarfic, clvar ! Nom des variables dans le fichier est sur la ligne de commande. + LOGICAL :: lrever = .FALSE. ! Si .true., on traite toutes les variables sauf celle de la ligne de commande + LOGICAL :: lnocoord = .FALSE. ! Si .truee., on exclu les variables coordonn�es + LOGICAL :: lverbose = .TRUE. + + INTEGER (kind=il) :: incid, ircode, ivarid, ivartype, inbdim, inbatt + INTEGER (kind=il) :: nvarcmd, nvarfic, nvar, nfile, jvarcmd, jvarfic, jvar, jfile, ierr + INTEGER (kind=il) :: ji, jdim3, jdim4, jdim5, jdim6, j1, j2, j3, jarg, ncumul + INTEGER (kind=il), DIMENSION(jpmaxdim) :: idimid, idimsize, istart, icount + REAL (kind=r4), DIMENSION(:,:), ALLOCATABLE :: zdatacorr + REAL (kind=r8), DIMENSION(:,:), ALLOCATABLE :: zdata + REAL (kind=r4) :: reps = TINY (1.0_r4) * 10.0_r4 + LOGICAL :: lok + + ! Verification du nombre de parametres + IF(iargc() .LT. 2) THEN + CALL usage + STOP + ENDIF + + ! Aide + jarg = 1 + Lab1: DO WHILE ( jarg <= 3 ) + IF (ldebug) WRITE(nout,*) 'lecture ligne commande ', jarg + CALL getarg (jarg,clecline) + IF ( clecline(1:1) /= '-' ) EXIT Lab1 + IF ( clecline(1:2) == '-h' .OR. clecline(1:2) == '-?' ) THEN + CALL usage + STOP + ELSE IF ( clecline(1:2) == '-x' ) THEN + lrever = .TRUE. + ELSE IF ( clecline(1:2) == '-d' ) THEN + ldebug = .TRUE. + ELSE IF ( clecline(1:2) == '-V' ) THEN + lverbose = .FALSE. + ELSE IF ( clecline(1:2) == '-v' ) THEN + jarg = jarg + 1 + ! Recuperation des noms de variables + IF (ldebug) WRITE(nout,*) 'lecture liste vriables ', jarg + CALL getarg (jarg,clistvar) + clistvar = TRIM(ADJUSTL(clistvar)) + jvarcmd = 0 ; nvarcmd = 0 + SeekVar: DO WHILE ( .TRUE. ) + CALL lec ( clistvar, clvarcmd(jvarcmd+1)(:) ) + IF ( TRIM(clvarcmd(jvarcmd+1)(:)) == cerror ) EXIT SeekVar + jvarcmd = jvarcmd + 1 + nvarcmd = jvarcmd + IF (ldebug) WRITE(nout,*) 'affecte variable ', jvarcmd, TRIM(clvarcmd(jvarcmd)) + END DO SeekVar + ENDIF + jarg = jarg + 1 + END DO Lab1 + + ! Boucle sur les fichiers + FileLoop: DO jfile = jarg, iargc() + + ! Recuperation du nom du fichier a traiter + CALL getarg ( jfile, clnomfic) + + ! Ouverture du fichier + CALL nfdiag ( NF_OPEN ( TRIM(clnomfic), NF_WRITE, incid ), "Opening " // TRIM(clnomfic) ) + WRITE (nout,*) TRIM(clnomfic) + + ! Recuparation de la liste des variables du fichier + nvarfic = 0 + DO jvarfic = 1, jpmaxvar + j3 = NF_INQ_VAR ( incid, jvarfic, clvarfic(jvarfic)(:), ivartype, inbdim, idimid, inbatt) + IF ( j3 /= NF_NOERR ) EXIT + nvarfic = jvarfic + END DO + + ! Liste des variables a traiter + IF ( lrever ) THEN + IF ( nvarcmd == 0) THEN + clvar = clvarfic + nvar = nvarfic + ELSE + jvar = 0 + DO jvarfic = 1, nvarfic + lok = .TRUE. + DO jvarcmd = 1, nvarcmd + IF ( TRIM(clvarfic(jvarfic)(:)) == TRIM(clvarcmd(jvarcmd)(:)) ) THEN + lok = .FALSE. + END IF + END DO + IF ( lok) THEN + jvar = jvar + 1 + clvar(jvar) = clvarfic(jvarfic) + END IF + END DO + nvar = jvar + END IF + ELSE + clvar = clvarcmd + nvar = nvarcmd + END IF + + ncumul = 0 + VarLoop: DO jvar = 1, nvar + + IF (lverbose) & + & WRITE(nout, FMT='("Correction de ", A, " dans ", A, " : ", $)') TRIM(clvar(jvar)(:)), TRIM(clnomfic) + + ! Passage de netcdf en mode 'erreurs non fatales' + ! CALL ncpopt(NCVERBOS) + ! En fait, on reste dans le mode par defaut, dans lequel une erreur + ! netcdf cause un arret du programme. Du coup, il n'est pas + ! necessaire de tester la valeur de la variable ircode + ! ATTENTION! Si jamais on veut arreter le programme a cause d'une + ! erreur ne provenant pas de netcdf, il faut penser a fermer + ! manuellement le fichier avec un appel a ncclos + + ! Recuperation de l'identificateur de la variable + CALL nfdiag ( NF_INQ_VARID ( incid, TRIM(clvar(jvar)(:)), ivarid), "Get var id " // TRIM(clvar(jvar)(:))) + + ivartype = 0 ; idimid = 0 ; inbdim = 0 ; inbatt = 0 + ! Recuperation du nombre de dimensions de la variable + CALL nfdiag ( NF_INQ_VAR ( incid, ivarid, clvar(jvar)(:), ivartype, inbdim, idimid, inbatt), & + & "Get var info " // TRIM(clvar(jvar)(:))) + + IF(inbdim .GT. jpmaxdim) THEN + WRITE(nout,*) + WRITE(nout, *) 'La variable ', TRIM(clvar(jvar)(:)), ' a trop de dimensions' + CALL nfdiag ( NF_CLOSE (incid), "Closing file") + STOP + ENDIF + + ! Recuperation des dimensions effectives + idimsize(3:jpmaxdim) = 1 ! Au cas ou la variable n'ait que + ! 2 ou 3 dims, on initialise ces valeurs + ! qui serviront dans le controle des boucles + ! et qui auraient une valeur indefinie sinon + DO ji = 1, inbdim + CALL nfdiag ( NF_INQ_DIM ( incid, idimid(ji), clnomdim(ji), idimsize(ji)), "NF_INQ_DIM") + IF (lverbose) WRITE(nout, '(A,A,A,I3,$)') ' ', TRIM(clnomdim(ji)), ' = ', idimsize(ji) + IF ( idimsize(ji) == 0 ) THEN + WRITE(nout, '(A,A,A,A,I3)') TRIM(clvar(jvar)(:)), ', ', TRIM(clnomdim(ji)), ' = ', idimsize(ji) + CYCLE VarLoop + END IF + ENDDO + IF (lverbose) WRITE(nout,*) + idimsize = MAX ( idimsize, 1) + ncumul = ncumul + 1 + + ! Determination du type de la variable, en fonction du nom de + ! la premiere dimension +!$$$ IF(INDEX(TRIM(clnomdim(1)),'ongitude') .NE. 0) THEN +!$$$ ! var de type map ou 3d +!$$$ write(nout, *) ' --> MAP/3D' +!$$$ ELSE IF(INDEX(TRIM(clnomdim(1)),'atitude') .NE. 0) THEN +!$$$ ! var de type xsec +!$$$ write(nout, *) ' --> XSEC' +!$$$ ELSE +!$$$ WRITE(nout, *) +!$$$ WRITE(nout, *) 'Bizarre, la premiere dimension n''est ni "longitude" ni "latitude"' +!$$$ CALL ncclos(incid, ircode) +!$$$ STOP +!$$$ ENDIF + + ! Reservation de memoire pour charger et traiter + ! une grille idimsize(1)*idimsize(2) de la variable + ALLOCATE(zdata(idimsize(1), idimsize(2)), stat=ierr) + IF(ierr .NE. 0) THEN + WRITE(nout, *) 'Erreur d''allocation memoire pour zdata' + CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE") + STOP + ENDIF + ALLOCATE(zdatacorr(idimsize(1), idimsize(2)), stat=ierr) + IF(ierr .NE. 0) THEN + WRITE(nout, *) 'Erreur d''allocation memoire pour zdatacorr' + CALL nfdiag ( NF_CLOSE (incid), "NF_CLOSE") + STOP + ENDIF + + ! Parametrisation de la partie de la variable a charger en memoire + ! (une 'grille' que l'on lira autant de fois qu'il y a de niveaux et + ! de pas de temps) + ! Rappel : seuls les elements 1..inbdim des tableaux sont + ! significatifs et utiles + + icount = 0 + + DO jdim6 = 1, idimsize(6) + DO jdim5 = 1, idimsize(5) + DO jdim4 = 1, idimsize(4) + DO jdim3 = 1, idimsize(3) + istart = (/ 1 , 1 , jdim3, jdim4, jdim5, jdim6 /) + icount = (/ idimsize(1), idimsize(2), 1 , 1 , 1 , 1 /) + + ! Chargement d'une 'grille' de donnees, en real*8 + CALL nfdiag ( NF_GET_VARA_DOUBLE(incid, ivarid, istart(1:inbdim), icount(1:inbdim), zdata), & + & "NF_GET_VARA_DOUBLE") + ! Mise a zero de toutes les valeurs trop petites pour etre + ! representees par un reel sur 4 octets au format IEEE. + ! Le truc est de faire une operation nulle (addition de 0) + ! sur des donnees qui posent problemes, EN AYANT COMPILE LE PROG + ! AVEC l'OPTION "-fpe1". Dans ce cas, les valeurs trop petites + ! sont remplacees par zero (0.0) et le programme continue, + ! au lieu de planter. + ! Il est possible de faire afficher le nb de valeurs qui ont pose + ! un pb en utilisant en plus l'option "-check underflow" + zdata = zdata + 0.0_r8 + zdatacorr = REAL(zdata, KIND=r4) + WHERE ( ABS (zdatacorr) < reps) zdatacorr = 0.0_r4 + + ! Sauvegarde de la grille corrigee dans le fichier + ! (a la place de la grille initiale), en real*4 + CALL nfdiag ( NF_PUT_VARA_REAL(incid, ivarid, istart, icount, zdatacorr), "NF_PUT_VARA_REAL" ) + + END DO + END DO + END DO + END DO + + DEALLOCATE ( zdata) + DEALLOCATE ( zdatacorr) + + END DO VarLoop + + WRITE (nout,*) 'ncunderflow, nombre de variables corrigees : ', ncumul + + ! Fermeture du fichier + CALL nfdiag ( NF_CLOSE (incid), "Closing" ) + + END DO FileLoop + +CONTAINS + SUBROUTINE usage + IMPLICIT NONE + CALL getarg (0, clnomprog) + + WRITE(nout, FMT='("Command : ", A)') TRIM(clnomprog) + WRITE(nout, FMT='("Removes underflows in NetCDF files") ') + WRITE(nout, FMT='("Usage : ", A, " [-x] [-V] [-d] -v nomvar[,nomvar] nomfic [nomfic]")' ) TRIM(clnomprog) + WRITE(nout, FMT='("Options : ")' ) + WRITE(nout, FMT='(" -V : mode verbose off. Default is verbose on.")' ) + WRITE(nout, FMT='(" -d : debug mode on. Default is debug off.")' ) + WRITE(nout, FMT='(" -v : gives list of variables to be corrected, separated by a coma.")' ) + WRITE(nout, FMT='(" -x : reverses meaning of -v : given variable are not corrected")' ) + WRITE(nout, FMT='(" if -x is given, and not -v, all variables are corrected.")' ) + + + STOP + END SUBROUTINE usage + +END PROGRAM ncunderflow diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/rebuild b/NEMO_4.0.4_surge/ext/IOIPSL/tools/rebuild new file mode 100755 index 0000000..f05d39a --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/rebuild @@ -0,0 +1,110 @@ +#!/bin/ksh +# +#$Id: rebuild 2281 2010-10-15 14:21:13Z smasson $ +# +# This software is governed by the CeCILL license +# See IOIPSL/IOIPSL_License_CeCILL.txt +#--------------------------------------------------------------------- +# @(#)Rebuild IOIPSL domains +#--------------------------------------------------------------------- +function rebuild_Usage +{ +print - " +\"${b_n}\" + rebuild a model_file from several input files. +Each input file contains the model_data for a domain. + +Usage : + ${b_n} [-h] + ${b_n} [-v level] [-f] -o output_file_name input_file_names + +Options : + -h : help + -v O/1/2/3 : verbose mode (verbosity increasing with level) + -f : executing mode + (execute the program even if the number of input files + is not equal to the total number of domains) +" +} +#- +#set -xv +#- +# Extract the calling sequence of the script (d_n/b_n) +#- +d_n=${0%/*}; b_n=${0##*/}; +#- +# Retrieving the options +#- +r_v='0'; r_f='noforce'; r_o=""; +while getopts :hv:fo: V + do + case $V in + (h) rebuild_Usage; exit 0;; + (v) r_v=${OPTARG};; + (f) r_f='force';; + (o) r_o=${OPTARG};; + (:) print -u2 "${b_n} : missing value for option $OPTARG"; exit 2;; + (\?) print -u2 "${b_n} : option $OPTARG not supported"; exit 2;; + esac + done +shift $(($OPTIND-1)); +#- +# Validate the -v option +#- +case ${r_v} in + ( 0 | 1 | 2 | 3 );; + ("") r_v='0';; + (*) + print -u2 "${b_n} :"; + print -u2 "Invalid verbosity level requested : ${r_v}"; + print -u2 "(must be 0, 1, 2 or 3)"; + exit 1;; +esac +#- +# Validate the number of arguments +#- +[[ ${#} < 1 ]] && \ + { + print -u2 "${b_n} : Too few arguments have been specified. (Use -h)"; + exit 3; + } +#- +# Check for the output file name +#- +[[ -z ${r_o} ]] && \ + { + r_o='rebuilt_file.nc'; + print -u2 - " + ${b_n} : output_file_name not specified. (Use -h) + rebuilt_file.nc should be created." + } +#- +# Validate the names of the input files +#- +for i in $*; + do + [[ ! -f ${i} ]] && { echo "${i} unreachable ..."; exit 3;} + done +#- +# Create the information file for the program +#- +echo ${r_v} > tmp.$$; +echo ${r_f} >> tmp.$$; +echo $((${#}+1)) >> tmp.$$; +for i in $*; + do echo ${i} >> tmp.$$; + done +echo ${r_o} >> tmp.$$; +#- +# Create the output file +#- +${d_n}/flio_rbld.exe < tmp.$$ +r_c=$? +#- +# Clear +#- +rm -f tmp.$$ +#- +# End +#- +exit ${r_c}; diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkcond.c b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkcond.c new file mode 100644 index 0000000..b7afe83 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkcond.c @@ -0,0 +1,546 @@ +/* parser config.in + * $Id: tkcond.c 2281 2010-10-15 14:21:13Z smasson $ + * + * This software is governed by the CeCILL license + * See IOIPSL/IOIPSL_License_CeCILL.txt + * + * Version 1.0 + * Eric Youngdale + * 10/95 + * + * The general idea here is that we want to parse a config.in file and + * from this, we generate a wish script which gives us effectively the + * same functionality that the original config.in script provided. + * + * This task is split roughly into 3 parts. The first parse is the parse + * of the input file itself. The second part is where we analyze the + * #ifdef clauses, and attach a linked list of tokens to each of the + * menu items. In this way, each menu item has a complete list of + * dependencies that are used to enable/disable the options. + * The third part is to take the configuration database we have build, + * and build the actual wish script. + * + * This file contains the code to further process the conditions from + * the "ifdef" clauses. + * + * The conditions are assumed to be one of the following formats + * + * simple_condition:= "$VARIABLE" == y/n/m + * simple_condition:= "$VARIABLE != y/n/m + * + * simple_condition -a simple_condition + * + * If the input condition contains '(' or ')' it would screw us up, but for now + * this is not a problem. + */ +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include "tkparse.h" + + +/* + * Walk a condition chain and invert it so that the logical result is + * inverted. + */ +static void invert_condition(struct condition * cnd) +{ + /* + * This is simple. Just walk through the list, and invert + * all of the operators. + */ + for(;cnd; cnd = cnd->next) + { + switch(cnd->op) + { + case op_and: + cnd->op = op_or; + break; + case op_or: + /* + * This is not turned into op_and - we need to keep track + * of what operators were used here since we have an optimization + * later on to remove duplicate conditions, and having + * inverted ors in there would make it harder if we did not + * distinguish an inverted or from an and we inserted because + * of nested ifs. + */ + cnd->op = op_and1; + break; + case op_neq: + cnd->op = op_eq; + break; + case op_eq: + cnd->op = op_neq; + break; + default: + break; + } + } +} + +/* + * Walk a condition chain, and free the memory associated with it. + */ +static void free_condition(struct condition * cnd) +{ + struct condition * next; + for(;cnd; cnd = next) + { + next = cnd->next; + + if( cnd->variable.str != NULL ) + free(cnd->variable.str); + + free(cnd); + } +} + +/* + * Walk all of the conditions, and look for choice values. Convert + * the tokens into something more digestible. + */ +void fix_choice_cond() +{ + struct condition * cond; + struct condition * cond2; + struct kconfig * cfg; + char tmpbuf[10]; + + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + if( cfg->cond == NULL ) + { + continue; + } + + for(cond = cfg->cond; cond != NULL; cond = cond->next) + { + if( cond->op != op_kvariable ) + continue; + + if( cond->variable.cfg->tok != tok_choice ) + continue; + + /* + * Look ahead for what we are comparing this to. There should + * be one operator in between. + */ + cond2 = cond->next->next; + strcpy(tmpbuf, cond->variable.cfg->label); + + if( strcmp(cond2->variable.str, "y") == 0 ) + { + cond->variable.cfg = cond->variable.cfg->choice_label; + cond2->variable.str = strdup(tmpbuf); + } + else + { + fprintf(stderr,"Ooops\n"); + exit(0); + } + } + + } +} + +/* + * Walk the stack of conditions, and clone all of them with "&&" operators + * gluing them together. The conditions from each level of the stack + * are wrapped in parenthesis so as to guarantee that the results + * are logically correct. + */ +struct condition * get_token_cond(struct condition ** cond, int depth) +{ + int i; + struct condition * newcond; + struct condition * tail; + struct condition * new; + struct condition * ocond; + struct kconfig * cfg; + + newcond = tail = NULL; + for(i=0; i<depth; i++, cond++) + { + /* + * First insert the left parenthesis + */ + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_lparen; + if( tail == NULL ) + { + newcond = tail = new; + } + else + { + tail->next = new; + tail = new; + } + + /* + * Now duplicate the chain. + */ + ocond = *cond; + for(;ocond != NULL; ocond = ocond->next) + { + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = ocond->op; + if( ocond->variable.str != NULL ) + { + if( ocond->op == op_variable ) + { + /* + * Search for structure to insert here. + */ + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_bool + && cfg->tok != tok_int + && cfg->tok != tok_hex + && cfg->tok != tok_tristate + && cfg->tok != tok_choice + && cfg->tok != tok_dep_tristate) + { + continue; + } + if( strcmp(cfg->optionname, ocond->variable.str) == 0) + { + new->variable.cfg = cfg; + new->op = op_kvariable; + break; + } + } + if( cfg == NULL ) + { + new->variable.str = strdup(ocond->variable.str); + } + } + else + { + new->variable.str = strdup(ocond->variable.str); + } + } + tail->next = new; + tail = new; + } + + /* + * Next insert the left parenthesis + */ + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_rparen; + tail->next = new; + tail = new; + + /* + * Insert an and operator, if we have another condition. + */ + if( i < depth - 1 ) + { + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_and; + tail->next = new; + tail = new; + } + + } + + return newcond; +} + +/* + * Walk a single chain of conditions and clone it. These are assumed + * to be created/processed by get_token_cond in a previous pass. + */ +struct condition * get_token_cond_frag(struct condition * cond, + struct condition ** last) +{ + struct condition * newcond; + struct condition * tail; + struct condition * new; + struct condition * ocond; + + newcond = tail = NULL; + + /* + * Now duplicate the chain. + */ + for(ocond = cond;ocond != NULL; ocond = ocond->next) + { + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = ocond->op; + new->variable.cfg = ocond->variable.cfg; + if( tail == NULL ) + { + newcond = tail = new; + } + else + { + tail->next = new; + tail = new; + } + } + + new = (struct condition *) malloc(sizeof(struct condition)); + memset(new, 0, sizeof(*new)); + new->op = op_and; + tail->next = new; + tail = new; + + *last = tail; + return newcond; +} + +/* + * Walk through the if conditionals and maintain a chain. + */ +void fix_conditionals(struct kconfig * scfg) +{ + int depth = 0; + int i; + struct kconfig * cfg; + struct kconfig * cfg1; + struct condition * conditions[25]; + struct condition * cnd; + struct condition * cnd1; + struct condition * cnd2; + struct condition * cnd3; + struct condition * newcond; + struct condition * last; + + /* + * Start by walking the chain. Every time we see an ifdef, push + * the condition chain on the stack. When we see an "else", we invert + * the condition at the top of the stack, and when we see an "endif" + * we free all of the memory for the condition at the top of the stack + * and remove the condition from the top of the stack. + * + * For any other type of token (i.e. a bool), we clone a new condition chain + * by anding together all of the conditions that are currently stored on + * the stack. In this way, we have a correct representation of whatever + * conditions govern the usage of each option. + */ + memset(conditions, 0, sizeof(conditions)); + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + switch(cfg->tok) + { + case tok_if: + /* + * Push this condition on the stack, and nuke the token + * representing the ifdef, since we no longer need it. + */ + conditions[depth] = cfg->cond; + depth++; + cfg->tok = tok_nop; + cfg->cond = NULL; + break; + case tok_else: + /* + * For an else, we just invert the condition at the top of + * the stack. This is done in place with no reallocation + * of memory taking place. + */ + invert_condition(conditions[depth-1]); + cfg->tok = tok_nop; + break; + case tok_fi: + depth--; + free_condition(conditions[depth]); + conditions[depth] = NULL; + cfg->tok = tok_nop; + break; + case tok_comment: + case tok_define: + case tok_menuoption: + case tok_bool: + case tok_tristate: + case tok_int: + case tok_hex: + case tok_choice: + case tok_make: + /* + * We need to duplicate the chain of conditions and attach them to + * this token. + */ + cfg->cond = get_token_cond(&conditions[0], depth); + break; + case tok_dep_tristate: + /* + * Same as tok_tristate et al except we have a temporary + * conditional. (Sort of a hybrid tok_if, tok_tristate, tok_fi + * option) + */ + conditions[depth] = cfg->cond; + depth++; + cfg->cond = get_token_cond(&conditions[0], depth); + depth--; + free_condition(conditions[depth]); + conditions[depth] = NULL; + default: + break; + } + } + + /* + * Fix any conditions involving the "choice" operator. + */ + fix_choice_cond(); + + /* + * Walk through and see if there are multiple options that control the + * same kvariable. If there are we need to treat them a little bit + * special. + */ + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + switch(cfg->tok) + { + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + for(cfg1=cfg;cfg1 != NULL; cfg1 = cfg1->next) + { + switch(cfg1->tok) + { + case tok_define: + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + if( strcmp(cfg->optionname, cfg1->optionname) == 0) + { + cfg->flags |= CFG_DUP; + cfg1->flags |= CFG_DUP; + } + break; + default: + break; + } + } + break; + default: + break; + } + } + + /* + * Now go through the list, and every time we see a kvariable, check + * to see whether it also has some dependencies. If so, then + * append it to our list. The reason we do this is that we might have + * option CONFIG_FOO which is only used if CONFIG_BAR is set. It may + * turn out that in config.in that the default value for CONFIG_BAR is + * set to "y", but that CONFIG_BAR is not enabled because CONFIG_XYZZY + * is not set. The current condition chain does not reflect this, but + * we can fix this by searching for the tokens that this option depends + * upon and cloning the conditions and merging them with the list. + */ + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + /* + * Search for a token that has a condition list. + */ + if(cfg->cond == NULL) continue; + for(cnd = cfg->cond; cnd; cnd=cnd->next) + { + /* + * Now search the condition list for a known configuration variable + * that has conditions of its own. + */ + if(cnd->op != op_kvariable) continue; + if(cnd->variable.cfg->cond == NULL) continue; + + if(cnd->variable.cfg->flags & CFG_DUP) continue; + /* + * OK, we have some conditions to append to cfg. Make a clone + * of the conditions, + */ + newcond = get_token_cond_frag(cnd->variable.cfg->cond, &last); + + /* + * Finally, we splice it into our list. + */ + last->next = cfg->cond; + cfg->cond = newcond; + + } + } + + /* + * There is a strong possibility that we have duplicate conditions + * in here. It would make the script more efficient and readable to + * remove these. Here is where we assume here that there are no + * parenthesis in the input script. + */ + for(cfg=scfg;cfg != NULL; cfg = cfg->next) + { + /* + * Search for configuration options that have conditions. + */ + if(cfg->cond == NULL) continue; + for(cnd = cfg->cond; cnd; cnd=cnd->next) + { + /* + * Search for a left parenthesis. + */ + if(cnd->op != op_lparen) continue; + for(cnd1 = cnd->next; cnd1; cnd1=cnd1->next) + { + /* + * Search after the previous left parenthesis, and try + * and find a second left parenthesis. + */ + if(cnd1->op != op_lparen) continue; + + /* + * Now compare the next 5 tokens to see if they are + * identical. We are looking for two chains that + * are like: '(' $VARIABLE operator constant ')'. + */ + cnd2 = cnd; + cnd3 = cnd1; + for(i=0; i<5; i++, cnd2=cnd2->next, cnd3=cnd3->next) + { + if(!cnd2 || !cnd3) break; + if(cnd2->op != cnd3->op) break; + if(i == 1 && (cnd2->op != op_kvariable + || cnd2->variable.cfg != cnd3->variable.cfg) ) break; + if(i==2 && cnd2->op != op_eq && cnd2->op != op_neq) break; + if(i == 3 && cnd2->op != op_constant && + strcmp(cnd2->variable.str, cnd3->variable.str) != 0) + break; + if(i==4 && cnd2->op != op_rparen) break; + } + /* + * If these match, and there is an and gluing these together, + * then we can nuke the second one. + */ + if(i==5 && ((cnd3 && cnd3->op == op_and) + ||(cnd2 && cnd2->op == op_and))) + { + /* + * We have a duplicate. Nuke 5 ops. + */ + cnd3 = cnd1; + for(i=0; i<5; i++, cnd3=cnd3->next) + { + cnd3->op = op_nuked; + } + /* + * Nuke the and that glues the conditions together. + */ + if(cnd3 && cnd3->op == op_and) cnd3->op = op_nuked; + else if(cnd2 && cnd2->op == op_and) cnd2->op = op_nuked; + } + } + } + } +} diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkgen.c b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkgen.c new file mode 100644 index 0000000..b42ea20 --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkgen.c @@ -0,0 +1,1136 @@ +/* Generate tk script based upon config.in + * $Id: tkgen.c 2281 2010-10-15 14:21:13Z smasson $ + * + * This software is governed by the CeCILL license + * See IOIPSL/IOIPSL_License_CeCILL.txt + * + * Version 1.0 + * Eric Youngdale + * 10/95 + * + * 1996 01 04 + * Avery Pennarun - Aesthetic improvements. + * + * 1996 01 24 + * Avery Pennarun - Bugfixes and more aesthetics. + * + * 1996 03 08 + * Avery Pennarun - The int and hex config.in commands work right. + * - Choice buttons are more user-friendly. + * - Disabling a text entry line greys it out properly. + * - dep_tristate now works like in Configure. (not pretty) + * - No warnings in gcc -Wall. (Fixed some "interesting" bugs.) + * - Faster/prettier "Help" lookups. + * + * 1996 03 15 + * Avery Pennarun - Added new sed script from Axel Boldt to make help even + * faster. (Actually awk is downright slow on some machines.) + * - Fixed a bug I introduced into Choice dependencies. Thanks + * to Robert Krawitz for pointing this out. + * + * 1996 03 16 + * Avery Pennarun - basic "do_make" support added to let sound config work. + * + * 1996 03 25 + * Axel Boldt - Help now works on "choice" buttons. + * + * 1996 04 06 + * Avery Pennarun - Improved sound config stuff. (I think it actually works + * now!) + * - Window-resize-limits don't use ugly /usr/lib/tk4.0 hack. + * - int/hex work with tk3 again. (The "cget" error.) + * - Next/Prev buttons switch between menus. I can't take + * much credit for this; the code was already there, but + * ifdef'd out for some reason. It flickers a lot, but + * I suspect there's no "easy" fix for that. + * - Labels no longer highlight as you move the mouse over + * them (although you can still press them... oh well.) + * - Got rid of the last of the literal color settings, to + * help out people with mono X-Windows systems. + * (Apparently there still are some out there!) + * - Tabstops seem sensible now. + * + * 1996 04 14 + * Avery Pennarun - Reduced flicker when creating windows, even with "update + * idletasks" hack. + * + * TO DO: + * - clean up - there are useless ifdef's everywhere. + * - better comments throughout - C code generating tcl is really cryptic. + * - eliminate silly "update idletasks" hack to improve display speed and + * reduce flicker. But how? + * - make canvas contents resize with the window (good luck). + * - some way to make submenus inside of submenus (ie. Main->Networking->IP) + * (perhaps a button where the description would be) + * - make the main menu use the same tcl code as the submenus. + * - make choice and int/hex input types line up vertically with + * bool/tristate. + * - general speedups - how? The canvas seems to slow it down a lot. + * - choice buttons should default to the first menu option, rather than a + * blank. Also look up the right variable when the help button + * is pressed. + * - clean up +/- 16 confusion for enabling/disabling variables; causes + * (theoretical, at the moment) problems with dependencies. + * + */ +#include <stdio.h> +#include <unistd.h> +#include "tkparse.h" + +#ifndef TRUE +#define TRUE (1) +#endif + +#ifndef FALSE +#define FALSE (0) +#endif + +/* + * This is the total number of submenus that we have. + */ +static int tot_menu_num =0; + +/* + * Generate portion of wish script for the beginning of a submenu. + * The guts get filled in with the various options. + */ +static void start_proc(char * label, int menu_num, int flag) +{ + if( flag ) + printf("menu_option menu%d %d \"%s\"\n", menu_num, menu_num, label); + printf("proc menu%d {w title} {\n", menu_num); + printf("\tcatch {destroy $w}\n"); + printf("\ttoplevel $w -class Dialog\n"); + printf("\twm withdraw $w\n"); + printf("\tmessage $w.m -width 400 -aspect 300 -text \\\n"); + printf("\t\t\"%s\" -relief raised\n",label); + printf("\tpack $w.m -pady 10 -side top -padx 10\n"); + printf("\twm title $w \"%s\" \n\n", label); + + /* + * Attach the "Prev", "Next" and "OK" buttons at the end of the window. + */ + printf("\tset oldFocus [focus]\n"); + printf("\tframe $w.f\n"); + printf("\tbutton $w.f.back -text \"Main Menu\" \\\n" + "\t\t-width 15 -command \"destroy $w; focus $oldFocus; update_mainmenu $w\"\n"); + printf("\tbutton $w.f.next -text \"Next\" \\\n" + "\t\t-width 15 -command \" destroy $w; focus $oldFocus; menu%d .menu%d \\\"$title\\\"\"\n", + menu_num+1, menu_num+1); + if (menu_num == tot_menu_num) + printf("\t$w.f.next configure -state disabled\n"); + printf("\tbutton $w.f.prev -text \"Prev\" \\\n" + "\t\t-width 15 -command \" destroy $w; focus $oldFocus; menu%d .menu%d \\\"$title\\\"\"\n", + menu_num-1, menu_num-1); + if (1 == menu_num) + printf("\t$w.f.prev configure -state disabled\n"); + printf("\tpack $w.f.back $w.f.next $w.f.prev -side left -expand on\n"); + printf("\tpack $w.f -pady 10 -side bottom -anchor w -fill x\n"); + + /* + * Lines between canvas and other areas of the window. + */ + printf("\tframe $w.topline -relief ridge -borderwidth 2 -height 2\n"); + printf("\tpack $w.topline -side top -fill x\n\n"); + printf("\tframe $w.botline -relief ridge -borderwidth 2 -height 2\n"); + printf("\tpack $w.botline -side bottom -fill x\n\n"); + + /* + * The "config" frame contains the canvas and a scrollbar. + */ + printf("\tframe $w.config\n"); + printf("\tpack $w.config -fill y -expand on\n\n"); + printf("\tscrollbar $w.config.vscroll -command \"$w.config.canvas yview\"\n"); + printf("\tpack $w.config.vscroll -side right -fill y\n\n"); + + /* + * The scrollable canvas itself, where the real work (and mess) gets done. + */ + printf("\tcanvas $w.config.canvas -height 1\\\n" + "\t\t-relief flat -borderwidth 0 -yscrollcommand \"$w.config.vscroll set\" \\\n" + "\t\t-width [expr [winfo screenwidth .] * 1 / 2] \n"); + printf("\tframe $w.config.f\n"); + printf("\tpack $w.config.canvas -side right -fill y\n"); + + printf("\n\n"); +} + +/* + * Each proc we create needs a global declaration for any global variables we + * use. To minimize the size of the file, we set a flag each time we output + * a global declaration so we know whether we need to insert one for a + * given function or not. + */ +void clear_globalflags(struct kconfig * cfg) +{ + for(; cfg != NULL; cfg = cfg->next) + { + cfg->flags &= ~GLOBAL_WRITTEN; + } +} + +/* + * Output a "global" line for a given variable. Also include the + * call to "vfix". (If vfix is not needed, then it's fine to just printf + * a "global" line). + */ +void global(char *var) +{ + printf("\tglobal %s; vfix %s\n", var, var); +} + +/* + * This function walks the chain of conditions that we got from cond.c, + * and creates a wish conditional to enable/disable a given widget. + */ +void generate_if(struct kconfig * item, + struct condition * cond, + int menu_num, + int line_num) +{ + struct condition * ocond; + + ocond = cond; + + /* + * First write any global declarations we need for this conditional. + */ + while(cond != NULL ) + { + switch(cond->op){ + case op_variable: + global(cond->variable.str); + break; + case op_kvariable: + if(cond->variable.cfg->flags & GLOBAL_WRITTEN) break; + cond->variable.cfg->flags |= GLOBAL_WRITTEN; + global(cond->variable.cfg->optionname); + break; + default: + break; + } + cond = cond->next; + } + + /* + * Now write this option. + */ + if( (item->flags & GLOBAL_WRITTEN) == 0 + && (item->optionname != NULL) ) + { + global(item->optionname); + item->flags |= GLOBAL_WRITTEN; + } + /* + * Now generate the body of the conditional. + */ + printf("\tif {"); + cond = ocond; + while(cond != NULL ) + { + switch(cond->op){ + case op_bang: + printf(" ! "); + break; + case op_eq: + printf(" == "); + break; + case op_neq: + printf(" != "); + break; + case op_and: + case op_and1: + printf(" && "); + break; + case op_or: + printf(" || "); + break; + case op_lparen: + printf("("); + break; + case op_rparen: + printf(")"); + break; + case op_variable: + printf("$%s", cond->variable.str); + break; + case op_kvariable: + printf("$%s", cond->variable.cfg->optionname); + break; + case op_shellcmd: + printf("[exec %s]", cond->variable.str); + break; + case op_constant: + if( strcmp(cond->variable.str, "y") == 0 ) + printf("1"); + else if( strcmp(cond->variable.str, "n") == 0 ) + printf("0"); + else if( strcmp(cond->variable.str, "m") == 0 ) + printf("2"); + else + printf("\"%s\"", cond->variable.str); + break; + default: + break; + } + cond = cond->next; + } + + /* + * Now we generate what we do depending upon the value of the conditional. + * Depending upon what the token type is, there are different things + * we must do to enable/disable the given widget - this code needs to + * be closely coordinated with the widget creation procedures in header.tk. + */ + switch(item->tok) + { + case tok_define: + printf("} then { set %s %s } \n", item->optionname, item->value); + break; + case tok_menuoption: + printf("} then { .f0.x%d configure -state normal } else { .f0.x%d configure -state disabled }\n", + menu_num, menu_num); + break; + case tok_int: + case tok_hex: + printf("} then { "); + printf(".menu%d.config.f.x%d.x configure -state normal -fore [ cget .ref -foreground ]; ", menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state normal; ", menu_num, line_num); + printf("} else { "); + printf(".menu%d.config.f.x%d.x configure -state disabled -fore [ cget .ref -disabledforeground ];", menu_num, line_num ); + printf(".menu%d.config.f.x%d.l configure -state disabled;", menu_num, line_num ); + printf("}\n"); + break; + case tok_bool: +#ifdef BOOL_IS_BUTTON + /* + * If a bool is just a button, then use this definition. + */ + printf("} then { .menu%d.config.f.x%d configure -state normal } else { .menu%d.config.f.x%d configure -state disabled }\n", + menu_num, line_num, + menu_num, line_num ); +#else + /* + * If a bool is a radiobutton, then use this instead. + */ + printf("} then { "); + printf(".menu%d.config.f.x%d.y configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.n configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state normal;",menu_num, line_num); + printf("set %s [expr $%s&15];", item->optionname, item->optionname); + printf("} else { "); + printf(".menu%d.config.f.x%d.y configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.n configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state disabled;",menu_num, line_num); + printf("set %s [expr $%s|16];", item->optionname, item->optionname); + printf("}\n"); +#endif + break; + case tok_tristate: + case tok_dep_tristate: + printf("} then { "); + if( item->tok == tok_dep_tristate ) + { + global(item->depend.str); + printf("if { $%s != 1 && $%s != 0 } then {", + item->depend.str,item->depend.str); + printf(".menu%d.config.f.x%d.y configure -state disabled;",menu_num, line_num); + printf("} else {"); + printf(".menu%d.config.f.x%d.y configure -state normal;",menu_num, line_num); + printf("}; "); + } + else + { + printf(".menu%d.config.f.x%d.y configure -state normal;",menu_num, line_num); + } + + printf(".menu%d.config.f.x%d.n configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.m configure -state normal;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state normal;",menu_num, line_num); + /* + * Or in a bit to the variable - this causes all of the radiobuttons + * to be deselected (i.e. not be red). + */ + printf("set %s [expr $%s&15];", item->optionname, item->optionname); + printf("} else { "); + printf(".menu%d.config.f.x%d.y configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.n configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.m configure -state disabled;",menu_num, line_num); + printf(".menu%d.config.f.x%d.l configure -state disabled;",menu_num, line_num); + /* + * Clear the disable bit - this causes the correct radiobutton + * to appear selected (i.e. turn red). + */ + printf("set %s [expr $%s|16];", item->optionname, item->optionname); + printf("}\n"); + break; + case tok_choose: + case tok_choice: + fprintf(stderr,"Fixme\n"); + exit(0); + default: + break; + } +} + +/* + * Similar to generate_if, except we come here when generating an + * output file. Thus instead of enabling/disabling a widget, we + * need to decide whether to write out a given configuration variable + * to the output file. + */ +void generate_if_for_outfile(struct kconfig * item, + struct condition * cond) +{ + struct condition * ocond; + + /* + * First write any global declarations we need for this conditional. + */ + ocond = cond; + for(; cond != NULL; cond = cond->next ) + { + switch(cond->op){ + case op_variable: + global(cond->variable.str); + break; + case op_kvariable: + if(cond->variable.cfg->flags & GLOBAL_WRITTEN) break; + cond->variable.cfg->flags |= GLOBAL_WRITTEN; + global(cond->variable.cfg->optionname); + break; + default: + break; + } + } + + /* + * Now generate the body of the conditional. + */ + printf("\tif {"); + cond = ocond; + while(cond != NULL ) + { + switch(cond->op){ + case op_bang: + printf(" ! "); + break; + case op_eq: + printf(" == "); + break; + case op_neq: + printf(" != "); + break; + case op_and: + case op_and1: + printf(" && "); + break; + case op_or: + printf(" || "); + break; + case op_lparen: + printf("("); + break; + case op_rparen: + printf(")"); + break; + case op_variable: + printf("$%s", cond->variable.str); + break; + case op_shellcmd: + printf("[exec %s]", cond->variable.str); + break; + case op_kvariable: + printf("$%s", cond->variable.cfg->optionname); + break; + case op_constant: + if( strcmp(cond->variable.str, "y") == 0 ) + printf("1"); + else if( strcmp(cond->variable.str, "n") == 0 ) + printf("0"); + else if( strcmp(cond->variable.str, "m") == 0 ) + printf("2"); + else + printf("\"%s\"", cond->variable.str); + break; + default: + break; + } + cond = cond->next; + } + + /* + * Now we generate what we do depending upon the value of the + * conditional. Depending upon what the token type is, there are + * different things we must do write the value the given widget - + * this code needs to be closely coordinated with the widget + * creation procedures in header.tk. + */ + switch(item->tok) + { + case tok_define: + printf("} then {write_tristate $cfg $autocfg %s %s $notmod }\n", item->optionname, item->value); + break; + case tok_comment: + printf("} then {write_comment $cfg $autocfg \"%s\"}\n", item->label); + break; + case tok_dep_tristate: + printf("} then { write_tristate $cfg $autocfg %s $%s $%s } \n", + item->optionname, item->optionname, item->depend.str); + break; + case tok_tristate: + case tok_bool: + printf("} then { write_tristate $cfg $autocfg %s $%s $notmod }\n", + item->optionname, item->optionname); + break; + case tok_int: + printf("} then { write_int $cfg $autocfg %s $%s $notmod }\n", + item->optionname, item->optionname); + break; + case tok_hex: + printf("} then { write_hex $cfg $autocfg %s $%s $notmod }\n", + item->optionname, item->optionname); + break; + case tok_make: + printf("} then { do_make {%s} }\n",item->value); + break; + case tok_choose: + case tok_choice: + fprintf(stderr,"Fixme\n"); + exit(0); + default: + break; + } +} + +/* + * Generates a fragment of wish script that closes out a submenu procedure. + */ +static void end_proc(int menu_num) +{ + struct kconfig * cfg; + + printf("\n\n\n"); + printf("\tfocus $w\n"); + printf("\tupdate_menu%d $w.config.f\n", menu_num); + printf("\tglobal winx; global winy\n"); + printf("\tset winx [expr [winfo x .]+30]; set winy [expr [winfo y .]+30]\n"); + printf("\twm geometry $w +$winx+$winy\n"); + + /* + * Now that the whole window is in place, we need to wait for an "update" + * so we can tell the canvas what its virtual size should be. + * + * Unfortunately, this causes some ugly screen-flashing because the whole + * window is drawn, and then it is immediately resized. It seems + * unavoidable, though, since "frame" objects won't tell us their size + * until after an update, and "canvas" objects can't automatically pack + * around frames. Sigh. + */ + printf("\tupdate idletasks\n"); + printf("\t$w.config.canvas create window 0 0 -anchor nw -window $w.config.f\n\n"); + printf("\t$w.config.canvas configure \\\n" + "\t\t-width [expr [winfo reqwidth $w.config.f] + 1]\\\n" + "\t\t-scrollregion \"-1 -1 [expr [winfo reqwidth $w.config.f] + 1] \\\n" + "\t\t\t [expr [winfo reqheight $w.config.f] + 1]\"\n\n"); + + /* + * If the whole canvas will fit in 3/4 of the screen height, do it; + * otherwise, resize to around 1/2 the screen and let us scroll. + */ + printf("\tset winy [expr [winfo reqh $w] - [winfo reqh $w.config.canvas]]\n"); + printf("\tset scry [expr [winfo screenh $w] / 2]\n"); + printf("\tset maxy [expr [winfo screenh $w] * 3 / 4]\n"); + printf("\tset canvtotal [expr [winfo reqh $w.config.f] + 2]\n"); + printf("\tif [expr $winy + $canvtotal < $maxy] {\n" + "\t\t$w.config.canvas configure -height $canvtotal\n" + "\t} else {\n" + "\t\t$w.config.canvas configure -height [expr $scry - $winy]\n" + "\t}\n"); + + /* + * Limit the min/max window size. Height can vary, but not width, + * because of the limitations of canvas and our laziness. + */ + printf("\tupdate idletasks\n"); + printf("\twm maxsize $w [winfo width $w] [winfo screenheight $w]\n"); + printf("\twm minsize $w [winfo width $w] 100\n\n"); + printf("\twm deiconify $w\n"); + + printf("}\n\n\n"); + + /* + * Now we generate the companion procedure for the menu we just + * generated. This procedure contains all of the code to + * disable/enable widgets based upon the settings of the other + * widgets, and will be called first when the window is mapped, + * and each time one of the buttons in the window are clicked. + */ + printf("proc update_menu%d {w} {\n", menu_num); + + printf("\tupdate_define\n"); + clear_globalflags(config); + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + /* + * Skip items not for this menu, or ones having no conditions. + */ + if (cfg->menu_number != menu_num ) continue; + if (cfg->tok != tok_define) continue; + /* + * Clear all of the booleans that are defined in this menu. + */ + if( (cfg->flags & GLOBAL_WRITTEN) == 0 + && (cfg->optionname != NULL) ) + { + printf("\tglobal %s\n", cfg->optionname); + cfg->flags |= GLOBAL_WRITTEN; + printf("\tset %s 0\n", cfg->optionname); + } + + } + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + /* + * Skip items not for this menu, or ones having no conditions. + */ + if (cfg->menu_number != menu_num ) continue; + if (cfg->tok == tok_menuoption) continue; + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, menu_num, cfg->menu_line); + else + { + /* + * If this token has no conditionals, check to see whether + * it is a tristate - if so, then generate the conditional + * to enable/disable the "y" button based upon the setting + * of the option it depends upon. + */ + if(cfg->tok == tok_dep_tristate) + { + global(cfg->depend.str); + printf("\tif {$%s != 1 && $%s != 0 } then { .menu%d.config.f.x%d.y configure -state disabled } else { .menu%d.config.f.x%d.y configure -state normal}\n", + cfg->depend.str,cfg->depend.str, + menu_num, cfg->menu_line, + menu_num, cfg->menu_line); + } + } + + } + + + printf("}\n\n\n"); +} + +/* + * This function goes through and counts up the number of items in + * each submenu. If there are too many options, we need to split it + * into submenus. This function just calculates how many submenus, + * and how many items go in each submenu. + */ +static void find_menu_size(struct kconfig *cfg, + int *menu_max, + int *menu_maxlines) + +{ + struct kconfig * pnt; + int tot; + + /* + * First count up the number of options in this menu. + */ + tot = 0; + for(pnt = cfg->next; pnt; pnt = pnt->next) + { + if( pnt->tok == tok_menuoption) break; + switch (pnt->tok) + { + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + case tok_choose: + tot++; + break; + case tok_choice: + default: + break; + } + } + + *menu_max = cfg->menu_number; + *menu_maxlines = tot; +} + +/* + * This is the top level function for generating the tk script. + */ +void dump_tk_script(struct kconfig *scfg) +{ + int menu_num =0; + int menu_max =0; + int menu_min =0; + int menu_line = 0; + int menu_maxlines = 0; + struct kconfig * cfg; + struct kconfig * cfg1 = NULL; + char * menulabel; + + /* + * Start by assigning menu numbers, and submenu numbers. + */ + for(cfg = scfg;cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_menuname: + break; + case tok_menuoption: + /* + * At the start of a new menu, calculate the number of items + * we will put into each submenu so we know when to bump the + * menu number. The submenus are really no different from a + * normal menu, but the top level buttons only access the first + * of the chain of menus, and the prev/next buttons are used + * access the submenus. + */ + cfg->menu_number = ++menu_num; + find_menu_size(cfg, &menu_max, &menu_maxlines); + cfg->submenu_start = menu_num; + cfg->submenu_end = menu_max; + menu_line = 0; + break; + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + case tok_choose: + /* + * If we have overfilled the menu, then go to the next one. + */ + if( menu_line == menu_maxlines ) + { + menu_line = 0; + menu_num++; + } + cfg->menu_number = menu_num; + cfg->submenu_start = menu_min; + cfg->submenu_end = menu_max; + cfg->menu_line = menu_line++; + break; + case tok_define: + cfg->menu_number = -1; + case tok_choice: + default: + break; + }; + } + + /* + * Record this so we can set up the prev/next buttons correctly. + */ + tot_menu_num = menu_num; + + /* + * Now start generating the actual wish script that we will use. + * We need to keep track of the menu numbers of the min/max menu + * for a range of submenus so that we can correctly limit the + * prev and next buttons so that they don't go over into some other + * category. + */ + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_menuname: + printf("mainmenu_name \"%s\"\n", cfg->label); + break; + case tok_menuoption: + /* + * We are at the start of a new menu. If we had one that + * we were working on before, close it out, and then generate + * the script to start the new one. + */ + if( cfg->menu_number > 1 ) + { + end_proc(menu_num); + } + menulabel = cfg->label; + start_proc(cfg->label, cfg->menu_number, TRUE); + menu_num = cfg->menu_number; + menu_max = cfg->submenu_end; + menu_min = cfg->submenu_start; + break; + case tok_bool: + /* + * If we reached the point where we need to switch over + * to the next submenu, then bump the menu number and generate + * the code to close out the old menu and start the new one. + */ + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tbool $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + + case tok_choice: + printf("\t$w.config.f.x%d.x.menu add radiobutton -label \"%s\" -variable %s -value \"%s\" -command \"update_menu%d .menu%d.config.f\"\n", + cfg1->menu_line, + cfg->label, + cfg1->optionname, + cfg->label, + cfg1->menu_number, cfg1->menu_number); + break; + case tok_choose: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tglobal %s\n",cfg->optionname); + printf("\tminimenu $w.config.f %d %d \"%s\" %s %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname, + /* + * We rely on the fact that the first tok_choice corresponding + * to the current tok_choose is cfg->next (compare parse() in + * tkparse.c). We need its name to pick out the right help + * text from Configure.help. + */ + cfg->next->optionname); + printf("\tmenu $w.config.f.x%d.x.menu\n", cfg->menu_line); + cfg1 = cfg; + break; + case tok_tristate: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\ttristate $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + case tok_dep_tristate: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tdep_tristate $w.config.f %d %d \"%s\" %s %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname, + cfg->depend.str); + break; + case tok_int: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\tint $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + case tok_hex: + if( cfg->menu_number != menu_num ) + { + end_proc(menu_num); + start_proc(menulabel, cfg->menu_number, FALSE); + menu_num = cfg->menu_number; + } + printf("\thex $w.config.f %d %d \"%s\" %s\n", + cfg->menu_number, + cfg->menu_line, + cfg->label, + cfg->optionname); + break; + default: + break; + } + + } + + /* + * Generate the code to close out the last menu. + */ + end_proc(menu_num); + +#ifdef ERIC_DONT_DEF + /* + * Generate the code for configuring the sound driver. Right now this + * cannot be done from the X script, but we insert the menu anyways. + */ + start_proc("Configure sound driver", ++menu_num, TRUE); +#if 0 + printf("\tdo_make -C drivers/sound config\n"); + printf("\techo check_sound_config %d\n",menu_num); +#endif + printf("\tlabel $w.config.f.m0 -bitmap error\n"); + printf("\tmessage $w.config.f.m1 -width 400 -aspect 300 -text \"The sound drivers cannot as of yet be configured via the X-based interface\" -relief raised\n"); + printf("\tpack $w.config.f.m0 $w.config.f.m1 -side top -pady 10 -expand on\n"); + /* + * Close out the last menu. + */ + end_proc(menu_num); +#endif + + /* + * The top level menu also needs an update function. When we exit a + * submenu, we may need to disable one or more of the submenus on + * the top level menu, and this procedure will ensure that things are + * correct. + */ + printf("proc update_mainmenu {w} {\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_menuoption: + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, cfg->menu_number, cfg->menu_line); + break; + default: + break; + } + } + + printf("}\n\n\n"); + +#if 0 + /* + * Generate some code to set the variables that are "defined". + */ + for(cfg = config;cfg != NULL; cfg = cfg->next) + { + /* + * Skip items not for this menu, or ones having no conditions. + */ + if( cfg->tok != tok_define) continue; + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, menu_num, cfg->menu_line); + else + { + printf("\twrite_define %s %s\n", cfg->optionname, cfg->value); + } + + } +#endif + + /* + * Now generate code to load the default settings into the variables. + * Note that the script in tail.tk will attempt to load .config, + * which may override these settings, but that's OK. + */ + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_choice: + printf("set %s 0\n", cfg->optionname); + break; + case tok_int: + case tok_hex: + printf("set %s %s\n", cfg->optionname, cfg->value); + break; + case tok_choose: + printf("set %s \"(not set)\"\n",cfg->optionname); + default: + break; + } + } + + /* + * Next generate a function that can be called from the main menu that will + * write all of the variables out. This also serves double duty - we can + * save configuration to a file using this. + */ + printf("proc writeconfig {file1 file2} {\n"); + printf("\tset cfg [open $file1 w]\n"); + printf("\tset autocfg [open $file2 w]\n"); + printf("\tset notmod 1\n"); + printf("\tset notset 0\n"); + clear_globalflags(config); + printf("\tputs $cfg \"#\"\n"); + printf("\tputs $cfg \"# Automatically generated make config: don't edit\"\n"); + printf("\tputs $cfg \"#\"\n"); + + printf("\tputs $autocfg \"/*\"\n"); + printf("\tputs $autocfg \" * Automatically generated C config: don't edit\"\n"); + printf("\tputs $autocfg \" */\"\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + switch (cfg->tok) + { + case tok_int: + case tok_hex: + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_define: + case tok_choose: + if(!(cfg->flags & GLOBAL_WRITTEN)) + { + cfg->flags |= GLOBAL_WRITTEN; + printf("\tglobal %s\n", cfg->optionname); + } + /* fall through */ + case tok_make: + case tok_comment: + if (cfg->cond != NULL ) + generate_if_for_outfile(cfg, cfg->cond); + else + { + if(cfg->tok == tok_dep_tristate) + { + printf("\tif {$%s == 0 } then {\n" + "\t\twrite_tristate $cfg $autocfg %s $notset $notmod\n" + "\t} else {\n" + "\t\twrite_tristate $cfg $autocfg %s $%s $%s\n" + "\t}\n", + cfg->depend.str, + cfg->optionname, + cfg->optionname, + cfg->optionname, + cfg->depend.str); + } + else if(cfg->tok == tok_comment) + { + printf("\twrite_comment $cfg $autocfg \"%s\"\n", cfg->label); + } +#if 0 + else if(cfg->tok == tok_define) + { + printf("\twrite_define %s %s\n", cfg->optionname, + cfg->value); + } +#endif + else if (cfg->tok == tok_choose ) + { + for(cfg1 = cfg->next; + cfg1 != NULL && cfg1->tok == tok_choice; + cfg1 = cfg1->next) + { + printf("\tif { $%s == \"%s\" } then { write_tristate $cfg $autocfg %s 1 $notmod }\n", + cfg->optionname, + cfg1->label, + cfg1->optionname); + } + } + else if (cfg->tok == tok_int ) + { + printf("\twrite_int $cfg $autocfg %s $%s $notmod\n", + cfg->optionname, + cfg->optionname); + } + else if (cfg->tok == tok_hex ) + { + printf("\twrite_hex $cfg $autocfg %s $%s $notmod\n", + cfg->optionname, + cfg->optionname); + } + else if (cfg->tok == tok_make ) + { + printf("\tdo_make {%s}\n",cfg->value); + } + else + { + printf("\twrite_tristate $cfg $autocfg %s $%s $notmod\n", + cfg->optionname, + cfg->optionname); + } + } + break; + default: + break; + } + } + printf("\tclose $cfg\n"); + printf("\tclose $autocfg\n"); + printf("}\n\n\n"); + + /* + * Finally write a simple function that updates the master choice + * variable depending upon what values were loaded from a .config + * file. + */ + printf("proc clear_choices { } {\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_choose ) continue; + for(cfg1 = cfg->next; + cfg1 != NULL && cfg1->tok == tok_choice; + cfg1 = cfg1->next) + { + printf("\tglobal %s; set %s 0\n",cfg1->optionname,cfg1->optionname); + } + } + printf("}\n\n\n"); + + printf("proc update_choices { } {\n"); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_choose ) continue; + printf("\tglobal %s\n", cfg->optionname); + for(cfg1 = cfg->next; + cfg1 != NULL && cfg1->tok == tok_choice; + cfg1 = cfg1->next) + { + printf("\tglobal %s\n", cfg1->optionname); + printf("\tif { $%s == 1 } then { set %s \"%s\" }\n", + cfg1->optionname, + cfg->optionname, + cfg1->label); + } + } + printf("}\n\n\n"); + + printf("proc update_define { } {\n"); + clear_globalflags(config); + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_define ) continue; + printf("\tglobal %s; set %s 0\n", cfg->optionname, cfg->optionname); + cfg->flags |= GLOBAL_WRITTEN; + } + for(cfg = scfg; cfg != NULL; cfg = cfg->next) + { + if( cfg->tok != tok_define ) continue; + if (cfg->cond != NULL ) + generate_if(cfg, cfg->cond, -1, 0); + else + { + printf("\tset %s %s\n", + cfg->optionname, cfg->value); + } + } + printf("}\n\n\n"); + /* + * That's it. We are done. The output of this file will have header.tk + * prepended and tail.tk appended to create an executable wish script. + */ +} diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkparse.c b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkparse.c new file mode 100644 index 0000000..b84ae8e --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkparse.c @@ -0,0 +1,755 @@ +/* parser config.in + * $Id: tkparse.c 2281 2010-10-15 14:21:13Z smasson $ + * + * This software is governed by the CeCILL license + * See IOIPSL/IOIPSL_License_CeCILL.txt + * + * Version 1.0 + * Eric Youngdale + * 10/95 + * + * The general idea here is that we want to parse a config.in file and + * from this, we generate a wish script which gives us effectively the + * same functionality that the original config.in script provided. + * + * This task is split roughly into 3 parts. The first parse is the parse + * of the input file itself. The second part is where we analyze the + * #ifdef clauses, and attach a linked list of tokens to each of the + * menu items. In this way, each menu item has a complete list of + * dependencies that are used to enable/disable the options. + * The third part is to take the configuration database we have build, + * and build the actual wish script. + * + * This file contains the code to do the first parse of config.in. + */ +#include <stdlib.h> +#include <stdio.h> +#include <string.h> +#include "tkparse.h" + +struct kconfig * config = NULL; +struct kconfig * clast = NULL; +struct kconfig * koption = NULL; +static int lineno = 0; +static int menus_seen = 0; +static char * current_file = NULL; +static int do_source(char * filename); +static char * get_string(char *pnt, char ** labl); +static int choose_number = 0; + + +/* + * Simple function just to skip over spaces and tabs in config.in. + */ +static char * skip_whitespace(char * pnt) +{ + while( *pnt && (*pnt == ' ' || *pnt == '\t')) pnt++; + return pnt; +} + +/* + * This function parses a conditional from a config.in (i.e. from an ifdef) + * and generates a linked list of tokens that describes the conditional. + */ +static struct condition * parse_if(char * pnt) +{ + char * opnt; + struct condition *list; + struct condition *last; + struct condition *cpnt; + char varname[64]; + char * pnt1; + + opnt = pnt; + + /* + * We need to find the various tokens, and build the linked list. + */ + pnt = skip_whitespace(pnt); + if( *pnt != '[' ) return NULL; + pnt++; + pnt = skip_whitespace(pnt); + + list = last = NULL; + while(*pnt && *pnt != ']') { + + pnt = skip_whitespace(pnt); + if(*pnt== '\0' || *pnt == ']') break; + + /* + * Allocate memory for the token we are about to parse, and insert + * it in the linked list. + */ + cpnt = (struct condition *) malloc(sizeof(struct condition)); + memset(cpnt, 0, sizeof(struct condition)); + if( last == NULL ) + { + list = last = cpnt; + } + else + { + last->next = cpnt; + last = cpnt; + } + + /* + * Determine what type of operation this token represents. + */ + if( *pnt == '-' && pnt[1] == 'a' ) + { + cpnt->op = op_and; + pnt += 2; + continue; + } + + if( *pnt == '-' && pnt[1] == 'o' ) + { + cpnt->op = op_or; + pnt += 2; + continue; + } + + if( *pnt == '!' && pnt[1] == '=' ) + { + cpnt->op = op_neq; + pnt += 2; + continue; + } + + if( *pnt == '=') + { + cpnt->op = op_eq; + pnt += 1; + continue; + } + + if( *pnt == '!') + { + cpnt->op = op_bang; + pnt += 1; + continue; + } + + if( *pnt != '"' ) goto error; /* This cannot be right. */ + pnt++; + if( *pnt == '`' ) + { + cpnt->op = op_shellcmd; + pnt1 = varname; + pnt++; + while(*pnt && *pnt != '`') *pnt1++ = *pnt++; + *pnt1++ = '\0'; + cpnt->variable.str = strdup(varname); + if( *pnt == '`' ) pnt++; + if( *pnt == '"' ) pnt++; + continue; + } + if( *pnt == '$' ) + { + cpnt->op = op_variable; + pnt1 = varname; + pnt++; + while(*pnt && *pnt != '"') *pnt1++ = *pnt++; + *pnt1++ = '\0'; + cpnt->variable.str = strdup(varname); + if( *pnt == '"' ) pnt++; + continue; + } + + cpnt->op = op_constant; + pnt1 = varname; + while(*pnt && *pnt != '"') *pnt1++ = *pnt++; + *pnt1++ = '\0'; + cpnt->variable.str = strdup(varname); + if( *pnt == '"' ) pnt++; + continue; + } + + return list; + + error: + if(current_file != NULL) + fprintf(stderr, + "Bad if clause at line %d(%s):%s\n", lineno, current_file, opnt); + else + fprintf(stderr, + "Bad if clause at line %d:%s\n", lineno, opnt); + return NULL; +} + +/* + * This function looks for a quoted string, from the input buffer, and + * returns a pointer to a copy of this string. Any characters in + * the string that need to be "quoted" have a '\' character inserted + * in front - this way we can directly write these strings into + * wish scripts. + */ +static char * get_qstring(char *pnt, char ** labl) +{ + char quotechar; + char newlabel[1024]; + char * pnt1; + char * pnt2; + + while( *pnt && *pnt != '"' && *pnt != '\'') pnt++; + if (*pnt == '\0') return pnt; + + quotechar = *pnt++; + pnt1 = newlabel; + while(*pnt && *pnt != quotechar && pnt[-1] != '\\') + { + /* + * Quote the character if we need to. + */ + if( *pnt == '"' || *pnt == '\'' || *pnt == '[' || *pnt == ']') + *pnt1++ = '\\'; + + *pnt1++ = *pnt++; + } + *pnt1++ = '\0'; + + pnt2 = (char *) malloc(strlen(newlabel) + 1); + strcpy(pnt2, newlabel); + *labl = pnt2; + + /* + * Skip over last quote, and whitespace. + */ + pnt++; + pnt = skip_whitespace(pnt); + return pnt; +} + +static char * parse_choices(struct kconfig * choice_kcfg, char * pnt) +{ + struct kconfig * kcfg; + int index = 1; + + /* + * Choices appear in pairs of strings. The parse is fairly trivial. + */ + while(1) + { + pnt = skip_whitespace(pnt); + if(*pnt == '\0') break; + + kcfg = (struct kconfig *) malloc(sizeof(struct kconfig)); + memset(kcfg, 0, sizeof(struct kconfig)); + kcfg->tok = tok_choice; + if( clast != NULL ) + { + clast->next = kcfg; + clast = kcfg; + } + else + { + clast = config = kcfg; + } + + pnt = get_string(pnt, &kcfg->label); + pnt = skip_whitespace(pnt); + pnt = get_string(pnt, &kcfg->optionname); + kcfg->choice_label = choice_kcfg; + kcfg->choice_value = index++; + if( strcmp(kcfg->label, choice_kcfg->value) == 0 ) + choice_kcfg->choice_value = kcfg->choice_value; + } + + return pnt; +} + + +/* + * This function grabs one text token from the input buffer + * and returns a pointer to a copy of just the identifier. + * This can be either a variable name (i.e. CONFIG_NET), + * or it could be the default value for the option. + */ +static char * get_string(char *pnt, char ** labl) +{ + char newlabel[1024]; + char * pnt1; + char * pnt2; + + if (*pnt == '\0') return pnt; + + pnt1 = newlabel; + while(*pnt && *pnt != ' ' && *pnt != '\t') + { + *pnt1++ = *pnt++; + } + *pnt1++ = '\0'; + + pnt2 = (char *) malloc(strlen(newlabel) + 1); + strcpy(pnt2, newlabel); + *labl = pnt2; + + if( *pnt ) pnt++; + return pnt; +} + + +/* + * Top level parse function. Input pointer is one complete line from config.in + * and the result is that we create a token that describes this line + * and insert it into our linked list. + */ +void parse(char * pnt) { + enum token tok; + struct kconfig * kcfg; + char tmpbuf[24],fake_if[1024]; + + /* + * Ignore comments and leading whitespace. + */ + + pnt = skip_whitespace(pnt); + while( *pnt && (*pnt == ' ' || *pnt == '\t')) pnt++; + if(! *pnt ) return; + if( *pnt == '#' ) return; + + /* + * Now categorize the next token. + */ + tok = tok_unknown; + if (strncmp(pnt, "mainmenu_name", 13) == 0) + { + tok = tok_menuname; + pnt += 13; + } + else if (strncmp(pnt, "source", 6) == 0) + { + pnt += 7; + pnt = skip_whitespace(pnt); + do_source(pnt); + return; + } + else if (strncmp(pnt, "mainmenu_option", 15) == 0) + { + menus_seen++; + tok = tok_menuoption; + pnt += 15; + } + else if (strncmp(pnt, "$MAKE ", 6) == 0) + { + tok = tok_make; + } + else if (strncmp(pnt, "comment", 7) == 0) + { + tok = tok_comment; + pnt += 7; + } + else if (strncmp(pnt, "choice", 6) == 0) + { + tok = tok_choose; + pnt += 6; + } + else if (strncmp(pnt, "define_bool", 11) == 0) + { + tok = tok_define; + pnt += 11; + } + else if (strncmp(pnt, "bool", 4) == 0) + { + tok = tok_bool; + pnt += 4; + } + else if (strncmp(pnt, "tristate", 8) == 0) + { + tok = tok_tristate; + pnt += 8; + } + else if (strncmp(pnt, "dep_tristate", 12) == 0) + { + tok = tok_dep_tristate; + pnt += 12; + } + else if (strncmp(pnt, "int", 3) == 0) + { + tok = tok_int; + pnt += 3; + } + else if (strncmp(pnt, "hex", 3) == 0) + { + tok = tok_hex; + pnt += 3; + } + else if (strncmp(pnt, "if", 2) == 0) + { + tok = tok_if; + pnt += 2; + } + else if (strncmp(pnt, "else", 4) == 0) + { + tok = tok_else; + pnt += 4; + } + else if (strncmp(pnt, "fi", 2) == 0) + { + tok = tok_fi; + pnt += 2; + } + else if (strncmp(pnt, "endmenu", 7) == 0) + { + tok = tok_endmenu; + pnt += 7; + } + + if( tok == tok_unknown) + { + if( clast != NULL && clast->tok == tok_if + && strcmp(pnt,"then") == 0) return; + if( current_file != NULL ) + fprintf(stderr, "unknown command=%s(%s %d)\n", pnt, + current_file, lineno); + else + fprintf(stderr, "unknown command=%s(%d)\n", pnt,lineno); + return; + } + + /* + * Allocate memory for this item, and attach it to the end of the linked + * list. + */ + kcfg = (struct kconfig *) malloc(sizeof(struct kconfig)); + memset(kcfg, 0, sizeof(struct kconfig)); + kcfg->tok = tok; + if( clast != NULL ) + { + clast->next = kcfg; + clast = kcfg; + } + else + { + clast = config = kcfg; + } + + pnt = skip_whitespace(pnt); + + /* + * Now parse the remaining parts of the option, and attach the results + * to the structure. + */ + switch (tok) + { + case tok_choose: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_qstring(pnt, &kcfg->optionname); + pnt = get_string(pnt, &kcfg->value); + /* + * Now we need to break apart the individual options into their + * own configuration structures. + */ + parse_choices(kcfg, kcfg->optionname); + free(kcfg->optionname); + sprintf(tmpbuf, "tmpvar_%d", choose_number++); + kcfg->optionname = strdup(tmpbuf); + break; + case tok_define: + pnt = get_string(pnt, &kcfg->optionname); + if(*pnt == 'y' || *pnt == 'Y' ) kcfg->value = "1"; + if(*pnt == 'n' || *pnt == 'N' ) kcfg->value = "0"; + if(*pnt == 'm' || *pnt == 'M' ) kcfg->value = "2"; + break; + case tok_menuname: + pnt = get_qstring(pnt, &kcfg->label); + break; + case tok_bool: + case tok_tristate: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_string(pnt, &kcfg->optionname); + break; + case tok_int: + case tok_hex: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_string(pnt, &kcfg->optionname); + pnt = get_string(pnt, &kcfg->value); + break; + case tok_dep_tristate: + pnt = get_qstring(pnt, &kcfg->label); + pnt = get_string(pnt, &kcfg->optionname); + pnt = skip_whitespace(pnt); + if( *pnt == '$') pnt++; + pnt = get_string(pnt, &kcfg->depend.str); + + /* + * Create a conditional for this object's dependency. + * + * We can't use "!= n" because this is internally converted to "!= 0" + * and if UMSDOS depends on MSDOS which depends on FAT, then when FAT + * is disabled MSDOS has 16 added to its value, making UMSDOS fully + * available. Whew. + * + * This is more of a hack than a fix. Nested "if" conditionals are + * probably affected too - that +/- 16 affects things in too many + * places. But this should do for now. + */ + sprintf(fake_if,"[ \"$%s\" = \"y\" -o \"$%s\" = \"m\" ]; then", + kcfg->depend.str,kcfg->depend.str); + kcfg->cond = parse_if(fake_if); + if(kcfg->cond == NULL ) + { + exit(1); + } + break; + case tok_comment: + pnt = get_qstring(pnt, &kcfg->label); + if( koption != NULL ) + { + pnt = get_qstring(pnt, &kcfg->label); + koption->label = kcfg->label; + koption = NULL; + } + break; + case tok_menuoption: + if( strncmp(pnt, "next_comment", 12) == 0) + { + koption = kcfg; + } + else + { + pnt = get_qstring(pnt, &kcfg->label); + } + break; + case tok_make: + kcfg->value=strdup(pnt); + break; + case tok_else: + case tok_fi: + case tok_endmenu: + break; + case tok_if: + /* + * Conditionals are different. For the first level parse, only + * tok_if and tok_dep_tristate items have a ->cond chain attached. + */ + kcfg->cond = parse_if(pnt); + if(kcfg->cond == NULL ) + { + exit(1); + } + break; + default: + exit(0); + } + + return; +} + +/* + * Simple function to dump to the screen what the condition chain looks like. + */ +void dump_if(struct condition * cond) +{ + printf(" "); + while(cond != NULL ) + { + switch(cond->op){ + case op_eq: + printf(" = "); + break; + case op_bang: + printf(" ! "); + break; + case op_neq: + printf(" != "); + break; + case op_and: + printf(" -a "); + break; + case op_lparen: + printf("("); + break; + case op_rparen: + printf(")"); + break; + case op_variable: + printf("$%s", cond->variable.str); + break; + case op_constant: + printf("'%s'", cond->variable.str); + break; + default: + break; + } + cond = cond->next; + } + + printf("\n"); +} + +static int do_source(char * filename) +{ + char buffer[1024]; + int offset; + int old_lineno; + char * old_file; + char * pnt; + FILE * infile; + + if( strcmp(filename, "-") == 0 ) + infile = stdin; + else + infile = fopen(filename,"r"); + + /* + * If our cwd was in the scripts directory, we might have to go up one + * to find the sourced file. + */ + if(!infile) { + strcpy (buffer, "../"); + strcat (buffer, filename); + infile = fopen(buffer,"r"); + } + + if(!infile) { + fprintf(stderr,"Unable to open file %s\n", filename); + return 1; + } + old_lineno = lineno; + lineno = 0; + if( infile != stdin ) { + old_file = current_file; + current_file = filename; + } + offset = 0; + while(1) + { + fgets(&buffer[offset], sizeof(buffer) - offset, infile); + if(feof(infile)) break; + + /* + * Strip the trailing return character. + */ + pnt = buffer + strlen(buffer) - 1; + if( *pnt == '\n') *pnt-- = 0; + lineno++; + if( *pnt == '\\' ) + { + offset = pnt - buffer; + } + else + { + parse(buffer); + offset = 0; + } + } + fclose(infile); + if( infile != stdin ) { + current_file = old_file; + } + lineno = old_lineno; + return 0; +} + +int main(int argc, char * argv[]) +{ +#if 0 + char buffer[1024]; + char * pnt; + struct kconfig * cfg; + int i; +#endif + + /* + * Read stdin to get the top level script. + */ + do_source("-"); + + if( menus_seen == 0 ) + { + fprintf(stderr,"The config.in file for this platform does not support\n"); + fprintf(stderr,"menus.\n"); + exit(1); + } + /* + * Input file is now parsed. Next we need to go through and attach + * the correct conditions to each of the actual menu items and kill + * the if/else/endif tokens from the list. We also flag the menu items + * that have other things that depend upon its setting. + */ + fix_conditionals(config); + + /* + * Finally, we generate the wish script. + */ + dump_tk_script(config); + +#if 0 + /* + * Now dump what we have so far. This is only for debugging so that + * we can display what we think we have in the list. + */ + for(cfg = config; cfg; cfg = cfg->next) + { + + if(cfg->cond != NULL && cfg->tok != tok_if) + dump_if(cfg->cond); + + switch(cfg->tok) + { + case tok_menuname: + printf("main_menuname "); + break; + case tok_bool: + printf("bool "); + break; + case tok_tristate: + printf("tristate "); + break; + case tok_dep_tristate: + printf("dep_tristate "); + break; + case tok_int: + printf("int "); + break; + case tok_hex: + printf("hex "); + break; + case tok_comment: + printf("comment "); + break; + case tok_menuoption: + printf("menuoption "); + break; + case tok_else: + printf("else"); + break; + case tok_fi: + printf("fi"); + break; + case tok_if: + printf("if"); + break; + default: + } + + switch(cfg->tok) + { + case tok_menuoption: + case tok_comment: + case tok_menuname: + printf("%s\n", cfg->label); + break; + case tok_bool: + case tok_tristate: + case tok_dep_tristate: + case tok_int: + case tok_hex: + printf("%s %s\n", cfg->label, cfg->optionname); + break; + case tok_if: + dump_if(cfg->cond); + break; + case tok_nop: + case tok_endmenu: + break; + default: + printf("\n"); + } + } +#endif + + return 0; + +} diff --git a/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkparse.h b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkparse.h new file mode 100644 index 0000000..911abdf --- /dev/null +++ b/NEMO_4.0.4_surge/ext/IOIPSL/tools/tkparse.h @@ -0,0 +1,82 @@ + +enum token { + tok_menuname, + tok_menuoption, + tok_comment, + tok_bool, + tok_tristate, + tok_dep_tristate, + tok_nop, + tok_if, + tok_else, + tok_fi, + tok_int, + tok_hex, + tok_make, + tok_define, + tok_choose, + tok_choice, + tok_endmenu, + tok_unknown +}; + +enum operator { + op_eq, + op_neq, + op_and, + op_and1, + op_or, + op_bang, + op_lparen, + op_rparen, + op_variable, + op_kvariable, + op_shellcmd, + op_constant, + op_nuked +}; + +union var +{ + char * str; + struct kconfig * cfg; +}; + +struct condition +{ + struct condition * next; + enum operator op; + union var variable; +}; + +#define GLOBAL_WRITTEN 1 +#define CFG_DUP 2 +#define UNSAFE 4 + +struct kconfig +{ + struct kconfig * next; + int flags; + enum token tok; + char menu_number; + char menu_line; + char submenu_start; + char submenu_end; + char * optionname; + char * label; + char * value; + int choice_value; + struct kconfig * choice_label; + union var depend; + struct condition * cond; +}; + +extern struct kconfig * config; +extern struct kconfig * clast; +extern struct kconfig * koption; + +/* + * Prototypes + */ +void fix_conditionals(struct kconfig * scfg); /* tkcond.c */ +void dump_tk_script(struct kconfig *scfg); /* tkgen.c */ diff --git a/NEMO_4.0.4_surge/makenemo b/NEMO_4.0.4_surge/makenemo new file mode 100755 index 0000000..e078235 --- /dev/null +++ b/NEMO_4.0.4_surge/makenemo @@ -0,0 +1,404 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# =============== +# makenemo +# =============== +# +# -------------------------- +# Compile NEMO +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ makenemo +# +# +# DESCRIPTION +# =========== +# +# +# This script aims : +# +# - to choose MYCONFIG +# - to choose compiler options +# - to create the CONFIG/MYCONFIG/WORK directory +# - to compile this configuration +# +# Variables used : +# +# From user input +# +# - NEW_CONF : configuration to be created +# - REF_CONF : reference configuration to build the new one from +# - CMP_NAM : compiler name +# - NBR_PRC : number of processes used to compile +# - RMT_CONF : unsupported (external) configuration to build the new one from +# - NEM_SUBDIR : NEMO subdirectory used (specified) +# +# Locally defined : +# +# - TAB : NEMO subdirectory used (read) +# - MAIN_DIR : self explaining +# - CONFIG_DIR : " " " +# - MODELES_DIR : " " " +# - TOOLS_DIR : " " " +# - NEMO_DIR : " " " +# - REMOTE_CTL : URL link to a remote resource list for an external configuration +# which is not part of the reference suite +# - LOCAL_REF : Nearest reference configuration to an external configuration +# which is not part of the reference suite +# (used to populate work directories if remote access is not available) +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./makenemo -m ifort_osx - j3 -n ORCA2_SI3_PISCES +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: makenemo 12191 2019-12-11 15:56:06Z jchanut $ +# +# +# +# * creation +# +#- + +#- +##- Initialization of the options --- +x_d=''; x_h=''; x_n=''; x_r=''; +x_u=''; x_a=''; x_m=''; x_t=''; +x_c=''; +x_j='1'; x_e='none'; x_s='src'; x_v='1' + +##- Local variables --- +b_n=$(basename ${0}) +OPTIND='1' +MAIN_DIR=$(cd $(dirname "$0"); pwd) +MAIN_DIR=${MAIN_DIR%/sette*} +MAIN_DIR=${MAIN_DIR%/tools*} +MAIN_DIR=${MAIN_DIR%/cfgs*} +export MAIN_DIR +# +export CONFIG_DIR=${MAIN_DIR}/cfgs +export TOOLS_DIR=${MAIN_DIR}/tools +export COMPIL_DIR=${MAIN_DIR}/mk +export NEMO_DIR=${MAIN_DIR}/${x_s} +export AGRIFUSE='10' +list_key='0'; chk_key='1' +list_add_key=''; list_del_key=''; +conf_file=ref_cfgs.txt +#- +#- FCM and functions location --- +export PATH=${MAIN_DIR}/ext/FCM/bin:$PATH + +#- +#- Choice of the options --- +while getopts :hd:n:r:u:a:m:j:e:s:v:t:k: option; do + + case $option in + ('h') cat <<EOF +Usage: +------ +./makenemo -[aru] CONFIG -m ARCH [-[dehjntv] ...] [{list_key,clean,clean_config}] + [{add_key,del_key} ...] + +Mandatory + -m Computing architecture (./arch), FCM file describing the compilation settings + + and one of the following option (use 'all' arg to list available items) + + -r Reference configuration (./cfgs), proven with long-term support + -a Academic test case (./tests), ready-to-use configuration with no support over time + -u Scripted remote configuration (see ./tests/rmt_cfgs.txt) + +Optional + -d New set of sub-components (subfolders from ./src directory) + -e Path for alter patch location (default: 'MY_SRC' in configuration folder) + -h Print this help + -j Number of processes to compile (0: dry run with no build) + -n Name for new configuration + -s Path for alter source location (default: 'src' root directory) + -t Path for alter build location (default: 'BLD' in configuration folder) + -v Level of verbosity ([0-3]) + +Examples + ¤ Configuration creation + Build : ./makenemo -[aru] ... [...] + Copy : ./makenemo -n ... -[aru] ... [...] + ¤ Configuration management + List CPP keys : ./makenemo -n ... list_key + Add-Remove keys: ./makenemo -n ... add_key '...' del_key '...' + Fresh start : ./makenemo -n ... clean + Removal : ./makenemo -n ... clean_config +EOF + exit 0 ;; + ('d') x_d=${OPTARG};; ('n') x_n=${OPTARG};; ('r') x_r=${OPTARG};; ('u') x_u=${OPTARG};; + ('a') x_a=${OPTARG};; ('m') x_m=${OPTARG};; ('j') x_j=${OPTARG};; ('t') x_t=${OPTARG};; + ('e') x_e=${OPTARG};; ('s') x_s=${OPTARG};; ('v') x_v=${OPTARG} ;; + ('k') chk_key=${OPTARG} ;; + (':') echo ${b_n}" : -"${OPTARG}" option : missing value" 1>&2; exit 2 ;; + ('?') echo ${b_n}" : -"${OPTARG}" option : not supported" 1>&2; exit 2 ;; + esac + +done + +shift $(($OPTIND-1)); + +## Get clean, clean_config options +while [ ${#1} -gt 0 ]; do + + case "$1" in + 'clean' ) x_c="--$1" ;; + 'clean_config') . ${COMPIL_DIR}/Fclean_config.sh; exit ;; + ## Checking if argument has anything other than whitespace + 'add_key' ) [[ ! "$2" =~ ^\ +$ ]] && list_add_key=$2; shift;; + 'del_key' ) [[ ! "$2" =~ ^\ +$ ]] && list_del_key=$2; shift;; + 'list_key' ) list_key='1' ;; + '*' ) echo " \"$1\" BAD OPTION"; exit 2 ;; + esac + + shift +done + + +export NEW_CONF=${x_n} +NBR_PRC=${x_j} +CMP_NAM=${x_m} +NEM_SUBDIR=${x_d} +REF_CONF=${x_r} +DEMO_CONF=${x_a} +RMT_CONF=${x_u} +TML_CONF=${REF_CONF} +export NEMO_DIR=${MAIN_DIR}/${x_s} + +[ "${CMP_NAM}" == 'all' ] && . ${COMPIL_DIR}/Flist_archfile.sh all && exit + + +## No ref. cfg, demo case, nor remote cfg selected +if [[ -z "${REF_CONF}" && -z "${DEMO_CONF}" && -z "${RMT_CONF}" ]]; then + + ## Reuse last configuration compiled if any (existing 'work_cfgs.txt') +# if [[ $( find ./cfgs ./tests -name work_cfgs.txt ) ]]; then +# CONFIG_DIR=${MAIN_DIR}/$( ls -rt */work_cfgs.txt | awk -F/ 'END{ print $1}' ) +# TML_CONF=$( tail -1 ${CONFIG_DIR}/work_cfgs.txt | awk '{ print $1 }' ) +# else + ## No ${REF_CONF}, ${DEMO_CONF}, ${RMT_CONF} nor ${NEM_SUBDIR} and 1st compilation => exit +# echo -e "\033[0;33m\nNo previous build found!" + echo -e "\033[0;31m\nAt least a reference configuration ('-r'), a test case ('-a'), " + echo -e "a remote configuration ('-u') has to be choosen!!!\033[0m" + ${COMPIL_DIR}/Flist_cfgs.sh + exit 2 +# fi + +## At least one config has been requested +else + + ## 'all' arg: list all available configurations + if [[ "${REF_CONF}" == 'all' || "${DEMO_CONF}" == 'all' || "${RMT_CONF}" == 'all' ]]; then + ${COMPIL_DIR}/Flist_cfgs.sh + exit 2 + ## Probably useless but who knows? + elif [[ -n "${REF_CONF}" && -n "${DEMO_CONF}" ]]; then + echo -e "\033[0;31m\nYou have to choose whether you work with:" + echo -e " - LTS configurations in ./cfgs ('-r') or" + echo -e " - Unsupported cases in ./tests ('-a')\033[0m\n" + exit 2 + fi + + ## Remote cfg + if [ -n "${RMT_CONF}" ]; then + conf_file=rmt_cfgs.txt; CONFIG_DIR=${MAIN_DIR}/tests; + + if [[ ! $( grep ${RMT_CONF} ${CONFIG_DIR}/${conf_file} ) ]]; then + echo -e "\033[0;31m\nThe reference configuration ('-r'), test case ('-a') or " + echo -e "remote configuration ('-u') selected is not available!!!" + echo -e "Check the option used and the available items in .txt files\033[0m" + ${COMPIL_DIR}/Flist_cfgs.sh + exit 2 + fi + + ## Little tricky this one + for word in $( grep ${RMT_CONF} ${CONFIG_DIR}/${conf_file} ); do + words[${#words[@]}]=$word + done + + TML_CONF=${words[2]}; NEM_SUBDIR=${words[4]}; URL=${words[6]} + + ## Demo case + elif [ -n "${DEMO_CONF}" ]; then + conf_file=demo_cfgs.txt; CONFIG_DIR=${MAIN_DIR}/tests; TML_CONF=${DEMO_CONF} + fi + +fi + +## Test if ref. cfg or demo case does exist +if [[ ! $( grep "${TML_CONF} " ${CONFIG_DIR}/*_cfgs.txt ) ]]; then + echo -e "\033[0;31m\nThe reference configuration ('-r'), demonstration case ('-a') or " + echo -e "remote configuration ('-u') selected is not available!!!" + echo -e "Check the option used and the available items in .txt files\033[0m" + ${COMPIL_DIR}/Flist_cfgs.sh + exit 2 + +else + + ## Reuse a working cfg + if [[ -f ${CONFIG_DIR}/work_cfgs.txt && $( grep "${TML_CONF} " ${CONFIG_DIR}/work_cfgs.txt ) ]]; then + conf_file=work_cfgs.txt + fi + + ## If new cfg exists, work in it + [ -z "${NEW_CONF}" ] && NEW_CONF=${TML_CONF} + + ## Update sub-comps if needed + if [ -z "${NEM_SUBDIR}" ]; then + NEM_SUBDIR=$( grep "${TML_CONF} " ${CONFIG_DIR}/${conf_file} | awk '{$1 = ""; print $0}' ) + fi + +fi + +export NEMO_TDIR=${x_t:-$CONFIG_DIR} + +## Save new configuration with sub-components set in work_cfgs.txt +[ -f ${CONFIG_DIR}/work_cfgs.txt ] && sed -i "/${NEW_CONF} /d" ${CONFIG_DIR}/work_cfgs.txt +echo ${NEW_CONF} "${NEM_SUBDIR}" \ + >> ${CONFIG_DIR}/work_cfgs.txt + +cd ${CONFIG_DIR} + +printf "\nYou are installing a new configuration %s from %s " ${NEW_CONF} ${TML_CONF} +printf "with sub-components: %s\n" "${NEM_SUBDIR}" + +## Create new config even in existing one (mkdir with -p option, cp with -n) +${COMPIL_DIR}/Fmake_config.sh ${NEW_CONF} ${TML_CONF} + +## create EXP00 if needed +[ ! -d ${CONFIG_DIR}/${NEW_CONF}/EXP00 ] && \cp -R -n ${CONFIG_DIR}/${NEW_CONF}/EXPREF ${CONFIG_DIR}/${NEW_CONF}/EXP00 + +## Get online script file for remote cfg +[ -n "${RMT_CONF}" ] && ${COMPIL_DIR}/Ffetch_extdir.sh ${NEW_CONF} $URL + +#- Create the WORK --- +#- Clean links and librairies --- +#- Creating the good links, at first on OCE --- +. ${COMPIL_DIR}/Fmake_WORK.sh ${x_e} ${NEW_CONF} ${NEM_SUBDIR} || exit 3 + +. ${COMPIL_DIR}/Fmake_bld.sh ${CONFIG_DIR} ${NEW_CONF} ${NEMO_TDIR} || exit 3 + +# build the complete list of the cpp keys of this configuration +if [ ${chk_key} -eq 1 ] ; then + + for i in $( grep "^ *#.* key_" ${NEW_CONF}/WORK/* ); do + echo $i | grep key_ | sed -e "s/=.*//" + done \ + | sort -d | uniq > ${COMPIL_DIR}/full_key_list.txt + + [ ${list_key} -eq 1 ] && cat ${COMPIL_DIR}/full_key_list.txt && exit 0 + +fi + +#- At this stage new configuration has been added, we add or remove keys +[ ! -z "${list_add_key}" ] && { . ${COMPIL_DIR}/Fadd_keys.sh ${NEW_CONF} add_key ${list_add_key}; } +[ ! -z "${list_del_key}" ] && { . ${COMPIL_DIR}/Fdel_keys.sh ${NEW_CONF} del_key ${list_del_key}; } + +#- check that all keys are really existing... +if [ $chk_key -eq 1 ] ; then + + for kk in $( cat ${NEW_CONF}/cpp_${NEW_CONF}.fcm ); do + + if [ "$( echo $kk | cut -c 1-4 )" == "key_" ]; then + kk=${kk/=*/} + + if [ ! $( grep $kk ${COMPIL_DIR}/full_key_list.txt ) ]; then + echo + echo "E R R O R : key "$kk" is not found in ${NEW_CONF}/WORK routines..." + echo "we stop..." + echo + exit 1 + fi + + fi + + done + +fi + +#- At this stage cpp keys have been updated. we can check the arch file +#- When used for the first time, choose a compiler --- +. ${COMPIL_DIR}/Fcheck_archfile.sh arch_nemo.fcm cpp.fcm ${CMP_NAM} || exit 3 + +#- At this stage the configuration has beeen chosen +#- We coose the default light file +export USEBLD=bldxag.cfg + +#- We look after agrif +grep key_agrif ${COMPIL_DIR}/cpp.fcm && export AGRIFUSE=1 && export USEBLD=${USEBLD/xag/} +. ${COMPIL_DIR}/Fprep_agrif.sh ${NEW_CONF} ${NEMO_TDIR} || exit 3 + +#- +#_ END OF CONFIGURATION PHASE +#_ + +#- +#- Compile --- + +if [ "${NBR_PRC}" -gt 0 ]; then + cd ${NEMO_TDIR}/${NEW_CONF} || cd - + + ## if AGRIF we do a first preprocessing + if [[ ${#x_c} -eq 0 && "$AGRIFUSE" -eq 1 ]]; then + fcm build --ignore-lock -j 1 ${COMPIL_DIR}/bld_preproagr.cfg ||{ cd - ; exit 1 ;} + echo '' + echo "---------------------------------" + echo "CONV preprocessing successfull !!" + echo "---------------------------------" + echo '' + fi + + fcm build ${x_c} --ignore-lock -v ${x_v} -j ${NBR_PRC} ${COMPIL_DIR}/$USEBLD ||{ cd - ; exit 1 ;} + + if [ -f ${NEMO_TDIR}/${NEW_CONF}/BLD/bin/nemo.exe ]; then + ln -sf ${NEMO_TDIR}/${NEW_CONF}/BLD/bin/nemo.exe ${CONFIG_DIR}/${NEW_CONF}/EXP00/nemo + fi + + ## add remove for clean option + if [ ${#x_c} -ne 0 ]; then + + echo 'Cleaning in '${NEW_CONF}' the building folders' + + for dir in AGRIFLIB BLD EXP00 LONG NEMOFILES REPRO_* SHORT WORK; do + rm -rf ${NEMO_TDIR}/${NEW_CONF}/$dir + done + + for file in cpp.history cpp.fcm full_key_list.txt; do + rm -f ${COMPIL_DIR}/$file + done + + fi + +fi + +#- Come back to original directory --- +cd - + +#- +#- Unset variables +${COMPIL_DIR}/Fclean_var.sh diff --git a/NEMO_4.0.4_surge/mk/Fadd_keys.sh b/NEMO_4.0.4_surge/mk/Fadd_keys.sh new file mode 100755 index 0000000..0aa554c --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fadd_keys.sh @@ -0,0 +1,77 @@ +#!/bin/bash +###################################################### +# Author : Simona Flavoni for NEMO +# Contact : sflod@locean-ipsl.upmc.fr +# +# Some functions called from makenemo +# Fadd_keys : add keys in cpp.fcm file +###################################################### +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ============ +# Fadd_keys.sh +# ============ +# +# -------------------- +# Add compilation keys +# -------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fadd_keys.sh CONFIG_NAME add_key "LIST_KEYS" +# +# +# DESCRIPTION +# =========== +# +# +# Script to add a set of key when compiling a configuration. +# The list of key to be added has to be enclosed with " ". +# A 'sed' is performed to modify the CONFIG_NAME/cpp.fcm file to +# add the new key(s). +# +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fadd_keys.sh ORCA2_LIM add_key "key_mpp_rep" +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fadd_keys.sh 2158 2010-10-20 17:30:03Z sflod $ +# +# +# +# * creation +# +#- + echo "Adding keys in : ${NEW_CONF}" + for i in ${list_add_key} ; do + if [ "$(cat ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm | grep -c "\<$i\>" )" -ne 0 ] ; then + echo "key $i already present in cpp_${NEW_CONF}.fcm" + else + sed -e "s/$/ ${i}/" ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm > ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm.tmp + mv ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm.tmp ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm + echo "added key $i in ${NEW_CONF}" + fi + done + + unset -v list_add_key + diff --git a/NEMO_4.0.4_surge/mk/Fcheck_archfile.sh b/NEMO_4.0.4_surge/mk/Fcheck_archfile.sh new file mode 100755 index 0000000..1768f12 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fcheck_archfile.sh @@ -0,0 +1,215 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ================== +# Fcheck_archfile.sh +# ================== +# +# -------------------------- +# Check the compilation file +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fcheck_archfile.sh +# +# +# DESCRIPTION +# =========== +# +# +# Check the choice of the compiler. +# Three cases : +# +# - There was a previous choice +# - A new one has be specified, we use this one +# - No information, exit +# +# We use TOOLS/COMPILE/arch.fcm to see if something was chosen. +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fcheck_archfile.sh ARCHFILE CPPFILE COMPILER +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fcheck_archfile.sh 10449 2019-01-02 09:38:04Z andmirek $ +# +# +# +# * creation +# +#- +cpeval () +{ + cat > $2 << EOF + +#========================================================== +# Automatically generated by Fcheck_archfile.sh from +# $1 +#========================================================== + +EOF + while read line + do + eval "echo \"$line\" >> $2" + done < $1 +} +# cleaning related to the old version +rm -f $( find ${COMPIL_DIR} -type l -name $1 -print ) +# +if [ ${#3} -eq 0 ]; then # arch not specified + if [ ! -f ${COMPIL_DIR}/arch.history ]; then + echo "Warning !!!" + echo "NO compiler chosen" + echo "Try makenemo -h for help" + echo "EXITING..." + exit 1 + else # use the arch file defined in arch.history + myarch=$( cat ${COMPIL_DIR}/arch.history ) + if [ ! -f $myarch ]; then + echo "Warning !!!" + echo "previously used arch file no more found:" + echo $myarch + echo "EXITING..." + exit 1 + else + if [ -f ${COMPIL_DIR}/$1 ]; then + if [ "$2" != "nocpp" ] + then + # has the cpp keys file been changed since we copied the arch file in ${COMPIL_DIR}? + mycpp=$( ls -l ${COMPIL_DIR}/$2 | sed -e "s/.* -> //" ) + if [ "$mycpp" != "$( cat ${COMPIL_DIR}/cpp.history )" ]; then + echo $mycpp > ${COMPIL_DIR}/cpp.history + cpeval ${myarch} ${COMPIL_DIR}/$1 + fi + # has the cpp keys file been updated since we copied the arch file in ${COMPIL_DIR}? + mycpp=$( find -L ${COMPIL_DIR} -cnewer ${COMPIL_DIR}/$1 -name $2 -print ) + [ ${#mycpp} -ne 0 ] && cpeval ${myarch} ${COMPIL_DIR}/$1 + fi + # has myarch file been updated since we copied it in ${COMPIL_DIR}? + myarchdir=$( dirname ${myarch} ) + myarchname=$( basename ${myarch} ) + myarch=$( find -L $myarchdir -cnewer ${COMPIL_DIR}/$1 -name $myarchname -print ) + [ ${#myarch} -ne 0 ] && cpeval ${myarch} ${COMPIL_DIR}/$1 + else + cpeval ${myarch} ${COMPIL_DIR}/$1 + fi + fi + fi +else + nb=$( find ${MAIN_DIR}/arch -name arch-${3}.fcm -print | wc -l ) + if [ $nb -eq 0 ]; then # no arch file found + echo "Warning !!!" + echo "Compiler not existing" + echo "Try makenemo -h for help" + echo "EXITING..." + exit 1 + fi + if [ $nb -gt 1 ]; then # more than 1 arch file found + echo "Warning !!!" + echo "more than 1 arch file for the same compiler have been found" + find ${MAIN_DIR}/arch -name arch-${3}.fcm -print + echo "keep only 1" + echo "EXITING..." + exit 1 + fi + myarch=$( find ${MAIN_DIR}/arch -name arch-${3}.fcm -print ) + # we were already using this arch file ? + if [ "$myarch" == "$( cat ${COMPIL_DIR}/arch.history )" ]; then + if [ -f ${COMPIL_DIR}/$1 ]; then + if [ "$2" != "nocpp" ] + then + # has the cpp keys file been changed since we copied the arch file in ${COMPIL_DIR}? + mycpp=$( ls -l ${COMPIL_DIR}/$2 | sed -e "s/.* -> //" ) + if [ "$mycpp" != "$( cat ${COMPIL_DIR}/cpp.history )" ]; then + echo $mycpp > ${COMPIL_DIR}/cpp.history + cpeval ${myarch} ${COMPIL_DIR}/$1 + fi + # has the cpp keys file been updated since we copied the arch file in ${COMPIL_DIR}? + mycpp=$( find -L ${COMPIL_DIR} -cnewer ${COMPIL_DIR}/$1 -name $2 -print ) + [ ${#mycpp} -ne 0 ] && cpeval ${myarch} ${COMPIL_DIR}/$1 + fi + # has myarch file been updated since we copied it in ${COMPIL_DIR}? + myarch=$( find -L ${MAIN_DIR}/arch -cnewer ${COMPIL_DIR}/$1 -name arch-${3}.fcm -print ) + [ ${#myarch} -ne 0 ] && cpeval ${myarch} ${COMPIL_DIR}/$1 + else + cpeval ${myarch} ${COMPIL_DIR}/$1 + fi + else + if [ "$2" != "nocpp" ] + then + ls -l ${COMPIL_DIR}/$2 | sed -e "s/.* -> //" > ${COMPIL_DIR}/cpp.history + fi + echo ${myarch} > ${COMPIL_DIR}/arch.history + cpeval ${myarch} ${COMPIL_DIR}/$1 + fi +fi + +#- do we need xios library? +#- 2 cases: +#- in CONFIG directory looking for key_iomput +if [ "$1" == "arch_nemo.fcm" ] +then + if [ "$2" != "nocpp" ] + then + use_iom=$( sed -e "s/#.*$//" ${COMPIL_DIR}/$2 | grep -c key_iomput ) + else + use_iom=0 + fi + have_lxios=$( sed -e "s/#.*$//" ${COMPIL_DIR}/$1 | grep -c "\-lxios" ) + if [[ ( $use_iom -eq 0 ) && ( $have_lxios -ge 1 ) ]] + then + sed -e "s/-lxios//g" ${COMPIL_DIR}/$1 > ${COMPIL_DIR}/tmp$$ + mv -f ${COMPIL_DIR}/tmp$$ ${COMPIL_DIR}/$1 + fi +#- in TOOLS directory looking for USE xios +else + use_iom=$( egrep --exclude-dir=.svn -r USE ${NEW_CONF}/src/* | grep -c xios ) + have_lxios=$( sed -e "s/#.*$//" ${COMPIL_DIR}/$1 | grep -c "\-lxios" ) + if [[ ( $use_iom -eq 0 ) || ( $have_lxios != 1 ) ]] + then + sed -e "s/-lxios//g" ${COMPIL_DIR}/$1 > ${COMPIL_DIR}/tmp$$ + mv -f ${COMPIL_DIR}/tmp$$ ${COMPIL_DIR}/$1 + fi +fi + +#- do we need oasis libraries? +if [ "$2" != "nocpp" ] +then + use_oasis=$( sed -e "s/#.*$//" ${COMPIL_DIR}/$2 | grep -c key_oasis3 ) +else + use_oasis=0 +fi +#ignore use_oasis if XIOS_OASIS is set (doesn't matter to what value) +if [[ ! -z "$XIOS_OASIS" ]]; then + use_oasis=1 +fi +for liboa in psmile.MPI1 mct mpeu scrip mpp_io +do + have_liboa=$( sed -e "s/#.*$//" ${COMPIL_DIR}/$1 | grep -c "\-l${liboa}" ) + if [[ ( $use_oasis -eq 0 ) && ( $have_liboa -ge 1 ) ]] + then + sed -e "s/-l${liboa}//g" ${COMPIL_DIR}/$1 > ${COMPIL_DIR}/tmp$$ + mv -f ${COMPIL_DIR}/tmp$$ ${COMPIL_DIR}/$1 + fi +done + diff --git a/NEMO_4.0.4_surge/mk/Fcheck_config.sh b/NEMO_4.0.4_surge/mk/Fcheck_config.sh new file mode 100755 index 0000000..996047f --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fcheck_config.sh @@ -0,0 +1,87 @@ +#!/bin/bash +###################################################### +# Author : Rachid Benshila for NEMO +# Contact : rblod@locean-ipsl.upmc.fr +# +# Some functions called from makenemo +# Fcheck_config : config checking +###################################################### +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ================ +# Fcheck_config.sh +# ================ +# +# -------------------------- +# Check the configuration +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fcheck_config.sh FILENAME CONFNAME +# +# +# DESCRIPTION +# =========== +# +# +# Check the choice of the configuration: +# +# - Two cases +# - One is explicitely set +# - Nothing set, use the previous in use +# +# We use TOOLS/cfgs_DIR/cfg.txt to check if the configuration exists. +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fcheck_config.sh +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fcheck_config.sh 9598 2018-05-15 22:47:16Z nicolasmartin $ +# +# +# +# * creation +# +#- + +declare -a ZTAB +if [ ${#2} -eq 0 ]; then + tail -1 ${CONFIG_DIR}/$1 > ${CONFIG_DIR}/cfg.tmp + read -a ZTAB < ${CONFIG_DIR}/cfg.tmp + NEW_CONF=${ZTAB[0]} ; TAB=( ${ZTAB[@]:1} ) + \rm ${CONFIG_DIR}/cfg.tmp + echo "Warning !!!" + echo "No configuration specified" + echo "Use makenemo -n MYCONFIG" + echo "or makenemo -h for help" + echo "Using default configuration : ${NEW_CONF}" +fi +if [ "$1" == cfg.txt ]; then + cat ${CONFIG_DIR}/$1 | grep "${NEW_CONF} " > ${CONFIG_DIR}/cfg.tmp + read -a ZTAB < ${CONFIG_DIR}/cfg.tmp + NEW_CONF=${ZTAB[0]} ; TAB=( ${ZTAB[@]:1} ) + \rm ${CONFIG_DIR}/cfg.tmp +fi + +unset -v ZTAB diff --git a/NEMO_4.0.4_surge/mk/Fcheck_script.sh b/NEMO_4.0.4_surge/mk/Fcheck_script.sh new file mode 100755 index 0000000..cd29beb --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fcheck_script.sh @@ -0,0 +1,63 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ================ +# Fcheck_script.sh +# ================ +# +# -------------------------- +# Check +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fcheck_script.sh +# +# +# DESCRIPTION +# =========== +# +# +# Check if utilities are in the path, typically fcm. +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fcheck_script.sh fcm +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fcheck_script.sh 3294 2012-01-28 16:44:18Z rblod $ +# +# +# +# * creation +# +#- + +myscript=`which $1` +if [ ${#myscript} -eq 0 ]; then +echo "WARNING !!!" +echo "$1 has to be installed first" +echo "Exiting......................" +exit 1 +fi + +unset -v myscript diff --git a/NEMO_4.0.4_surge/mk/Fclean_config.sh b/NEMO_4.0.4_surge/mk/Fclean_config.sh new file mode 100755 index 0000000..6cb4a83 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fclean_config.sh @@ -0,0 +1,98 @@ +#!/bin/bash +###################################################### +# Author : Simona Flavoni for NEMO +# Contact : sflod@locean-ipsl.upmc.fr +# +# Some functions called from makenemo +# Fclean_config : config removing +###################################################### +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ================ +# Fclean_config.sh +# ================ +# +# ------------------------ +# Remove the configuration +# ------------------------ +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fclean_config.sh CONFNAME +# +# +# DESCRIPTION +# =========== +# +# +# Remove the configuration: +# +# - remove CONFIG_NAME/WORK +# - remove CONFIG_NAME/BLD +# - remove CONFIG_NAME from TOOLS/mk/cfg.txt +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fclean_config.sh ORCA2_LIM +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fclean_config.sh 2158 2010-10-20 17:30:03Z sflod $ +# +# +# +# * creation +# +#- + +NEW_CONF=${x_n} + +if [ ${#NEW_CONF} -eq 0 ] ; then + echo " " + echo "No configuration specified, please use makenemo -n CONFIG clean_config " +else + echo "Are you sure that you want to remove this directory $NEW_CONF? [y/n] " + read answer + answer=`echo $answer | sed 's/^[y].*$/y/'` + + if [ -z "$answer" -o "x$answer" = "xy" ]; then + + ## testing if configuration exists + if [[ ! $( grep "${NEW_CONF} " */work_cfgs.txt ) ]] ; then + echo "The configuration ${NEW_CONF} does not exist in file work_cfgs.txt" + echo "No removing configuration" + echo " " + else + CONFIG_DIR=${MAIN_DIR}/$( grep -l "${NEW_CONF} " */work_cfgs.txt | cut -d/ -f1 ) + rm -rf ${CONFIG_DIR}/${NEW_CONF} + sed -e "/${NEW_CONF} /d" ${CONFIG_DIR}/work_cfgs.txt > ${CONFIG_DIR}/work_cfgs.tmp + mv ${CONFIG_DIR}/work_cfgs.tmp ${CONFIG_DIR}/work_cfgs.txt + echo "${NEW_CONF} configuration REMOVED" + fi + + else + echo " " + echo "nothing to remove" + fi + +fi + +unset -v answer diff --git a/NEMO_4.0.4_surge/mk/Fclean_var.sh b/NEMO_4.0.4_surge/mk/Fclean_var.sh new file mode 100755 index 0000000..eb624c7 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fclean_var.sh @@ -0,0 +1,68 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ============= +# Fclean_var.sh +# ============= +# +# ---------------------------- +# Clean environment variables +# ---------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fclean_var.sh +# +# +# DESCRIPTION +# =========== +# +# +# Clean environment variables +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fclean_var.sh +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fclean_var.sh 4990 2014-12-15 16:42:49Z timgraham $ +# +# +# +# * creation +# +#- +#- Unset variables + +unset -v NSTOP +unset -v TAB +unset -v NEW_CONF +unset -v REF_CONF +unset -v CMP_NAM +unset -v NBR_PRC +unset -v NEM_SUBDIR +unset -v MAIN_DIR +unset -v CONFIG_DIR +unset -v TOOLS_DIR +unset -v COMPIL_DIR +unset -v NEMO_DIR +unset -v USEBLD diff --git a/NEMO_4.0.4_surge/mk/Fcopy_dir.sh b/NEMO_4.0.4_surge/mk/Fcopy_dir.sh new file mode 100755 index 0000000..e807ef6 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fcopy_dir.sh @@ -0,0 +1,62 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ============ +# Fcopy_dir.sh +# ============ +# +# -------------------------- +# Copy a reference directory +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fcopy_dir.sh +# +# +# DESCRIPTION +# =========== +# +# +# When a reference configuration is set, +# Copy NEMO sub-directories needed (OCE, TOP ...) +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fcopy_dir.sh ORCA2_LIM +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fcopy_dir.sh 9598 2018-05-15 22:47:16Z nicolasmartin $ +# +# +# +# * creation +# +#- + +declare -a ZTAB +grep "$1 " ${CONFIG_DIR}/cfg.txt > ${CONFIG_DIR}/cfg.tmp +read -a ZTAB < ${CONFIG_DIR}/cfg.tmp +TAB=( ${ZTAB[@]:1} ) +\rm ${CONFIG_DIR}/cfg.tmp + +unset -v ZTAB diff --git a/NEMO_4.0.4_surge/mk/Fcopy_extdir.sh b/NEMO_4.0.4_surge/mk/Fcopy_extdir.sh new file mode 100755 index 0000000..8ee08ed --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fcopy_extdir.sh @@ -0,0 +1,39 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# ============ +# Fcopy_extdir.sh +# ============ +# -------------------------- +# Copy a reference directory +# -------------------------- +# SYNOPSIS +# ======== +# :: +# $ Fcopy_extdir.sh +# DESCRIPTION +# =========== +# When an unsupported configuration is requested, +# Prepare sources for the NEMO sub-directories needed (OCE, TOP ...) +# EXAMPLES +# ======== +# :: +# $ ./Fcopy_extdir.sh ORCA2_LIM +# TODO +# ==== +# option debug +# EVOLUTIONS +# ========== +# $Id: Fcopy_extdir.sh 3294 2012-01-28 16:44:18Z rblod $ +# * creation +#- +grep "$1 " ${CONFIG_DIR}/uspcfg.txt > ${CONFIG_DIR}/cfg.tmp +# +LOCAL_REF=$(cat cfg.tmp | awk 'BEGIN {FS = "#" }{print $2}') +TAB=$(cat cfg.tmp | awk 'BEGIN {FS = "#" }{print $3}') +REMOTE_CTL=$(cat cfg.tmp | awk 'BEGIN {FS = "#" }{print $4}') +# +\rm ${CONFIG_DIR}/cfg.tmp diff --git a/NEMO_4.0.4_surge/mk/Fdel_keys.sh b/NEMO_4.0.4_surge/mk/Fdel_keys.sh new file mode 100755 index 0000000..88aafc2 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fdel_keys.sh @@ -0,0 +1,81 @@ +#!/bin/bash +###################################################### +# Author : Simona Flavoni for NEMO +# Contact : sflod@locean-ipsl.upmc.fr +# +# Some functions called from makenemo +# Fdel_keys : del keys in cpp.fcm file +###################################################### +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ================ +# Fdel_keys.sh +# ================ +# +# -------------------------- +# Add compilation keys +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fdel_keys.sh CONFIG_NAME del_key "LIST_KEYS" +# +# +# DESCRIPTION +# =========== +# +# +# Add cpp keys when compiling a configuration, key list has to be enclosed with " ". +# We perform a 'sed' on the CONFIG_NAME/CPP.fcm file, containing the list of keys. +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fdel_keys.sh CONFIG_NAME del_key "key_agrif" +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fdel_keys.sh 2158 2010-10-20 17:30:03Z sflod $ +# +# +# +# * creation +# +#- + +echo "Removing keys in : ${NEW_CONF}" + +for i in ${list_del_key} ; do + + if [ "$(echo ${i} | grep -c key_nproc )" -ne 0 ]; then + sed -e "s/key_nproc[ij]=.* //" ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm \ + > ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm.tmp + mv ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm.tmp ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm + echo " " + elif [ "$(cat ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm | grep -c "$i" )" -ne 0 ]; then + sed -e "s/\b${i}\b//" ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm \ + > ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm.tmp + mv ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm.tmp ${CONFIG_DIR}/${NEW_CONF}/cpp_${NEW_CONF}.fcm + echo "deleted key $i in ${NEW_CONF}" + fi + +done + +unset -v list_del_key diff --git a/NEMO_4.0.4_surge/mk/Ffetch_extdir.sh b/NEMO_4.0.4_surge/mk/Ffetch_extdir.sh new file mode 100755 index 0000000..9726a5f --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Ffetch_extdir.sh @@ -0,0 +1,53 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# =============== +# Ffetch_extdir.sh +# =============== +# --------------- +# Make the config +# --------------- +# SYNOPSIS +# ======== +# :: +# $ Ffetch_extdir.sh +# DESCRIPTION +# =========== +# - Make the config directory +# - Create repositories needed : +# +# - EXP00 for namelist +# - MY_SRC for user sources +# - BLD for compilation +# EXAMPLES +# ======== +# :: +# $ ./Ffetch_extdir.sh CONFIG_NAME REMOTE_CTL +# TODO +# ==== +# option debug +# EVOLUTIONS +# ========== +# $Id: Ffetch_extdir.sh 3715 2012-11-28 16:06:02Z acc $ +# * creation +#- +basedir=$(pwd) +cd ${1} +wget ${2} -O remote_file.list +# +if [ -f remote_file.list ] ; then + cat remote_file.list | grep -v '^#' | + while + read remfile locfile + do + if [ $remfile == 'create_directory' ] ;then + mkdir $locfile + else + wget $remfile -O $locfile + fi + done +fi +cd $basedir diff --git a/NEMO_4.0.4_surge/mk/Fgo_to_TOOLS.sh b/NEMO_4.0.4_surge/mk/Fgo_to_TOOLS.sh new file mode 100755 index 0000000..33f070d --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fgo_to_TOOLS.sh @@ -0,0 +1,55 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# =============== +# Fgo_to_tools.sh +# =============== +# +# -------------------------- +# Go to the TOOLS directory +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fgo_to_tools.sh +# +# +# DESCRIPTION +# =========== +# +# +# Go to the TOOLS directory +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fgo_to_tools.sh +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fgo_to_TOOLS.sh 9598 2018-05-15 22:47:16Z nicolasmartin $ +# +# +# +# * creation +# +#- + +cd ${MAIN_DIR}/tools diff --git a/NEMO_4.0.4_surge/mk/Flist_archfile.sh b/NEMO_4.0.4_surge/mk/Flist_archfile.sh new file mode 100755 index 0000000..46c570b --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Flist_archfile.sh @@ -0,0 +1,77 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ================== +# Flist_archfile.sh +# ================== +# +# -------------------------- +# Check the compilation file +# -------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Flist_archfile.sh Institute +# +# +# DESCRIPTION +# =========== +# +# +# List arch file available. +# The first line of each file in NEMO/arch directory is echoed. +# +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Flist_archfile.sh +# +# $ ./Flist_archfile.sh CNRS +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Flist_archfile.sh 9651 2018-05-28 06:47:14Z nicolasmartin $ +# +# +# +# * creation +# +#- + +archfile_loop() { + + for file in $( ls $1/*.fcm ); do + zvar1=$( basename $file | sed 's/arch-\(.*\).fcm/\1/' ) + zvar2=$( head -1 $file | tr -d '#' ) + printf "%-30s %-s\n" ${zvar1} "${zvar2}" + done + +} + +echo -e "\n ¤ Generic computing architectures" + +archfile_loop ${MAIN_DIR}/arch + +for dir in $( ls ${MAIN_DIR}/arch | grep -v "fcm$" ); do + echo -e "\n ¤ Specific HPC architectures for "${dir} + archfile_loop ${MAIN_DIR}/arch/$dir +done + +echo diff --git a/NEMO_4.0.4_surge/mk/Flist_cfgs.sh b/NEMO_4.0.4_surge/mk/Flist_cfgs.sh new file mode 100755 index 0000000..8a19b67 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Flist_cfgs.sh @@ -0,0 +1,17 @@ +#!/bin/bash + +echo -e "\n ¤ Reference configurations with default sub-components (can be updated by a new set)" +cat ${MAIN_DIR}/cfgs/ref_cfgs.txt \ +| awk '{printf "%-20s", $1}{$1 = ""; printf "%s\n", $0}' + +echo -e "\n ¤ Demonstrations cases (see https://github.com/sflavoni/NEMO-test-cases for more)" +cat ${MAIN_DIR}/tests/demo_cfgs.txt \ +| awk '{printf "%-20s", $1}{$1 = ""; printf "%s\n", $0}' + +echo -e "\n ¤ Full scripted remote configurations (CPP file + EXP00 inputs + MY_SRC + ...)" +cat ${MAIN_DIR}/tests/rmt_cfgs.txt + +echo -e "\n ¤ Available sub-components ('OCE' is mandatory in any set)" +ls ${MAIN_DIR}/src | awk -F/ '{ print $NF }' | column + +echo diff --git a/NEMO_4.0.4_surge/mk/Fmake_WORK.sh b/NEMO_4.0.4_surge/mk/Fmake_WORK.sh new file mode 100755 index 0000000..a2b44d2 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fmake_WORK.sh @@ -0,0 +1,99 @@ +#!/bin/bash +###################################################### +# Author : Rachid Benshila for NEMO +# Contact : rblod@locean-ipsl.upmc.fr +# +# Some functions called from makenemo +# Fmake_WORK : create links in the WORK +###################################################### +#set -vx +set -o posix +#set -u +#set -e +#+ +# +# ============= +# Fmake_WORK.sh +# ============= +# +# ----------------------- +# Make the WORK directory +# ----------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fmake_WORK.sh +# +# +# DESCRIPTION +# =========== +# +# +# Make the WORK directory: +# +# - Create line in NEW_CONF/WORK +# - Use specified sub-directories previously +# - OPA has to be done first !!! +# +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fmake_WORK.sh ORCA2_LIM OCE ICE +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fmake_WORK.sh 9651 2018-05-28 06:47:14Z nicolasmartin $ +# +# +# +# * creation +# +#- +declare ZSRC=$1 ; shift +declare ZCONF=$1 ; shift +ZTAB=( $@ ) +declare i=0 ; declare NDIR=${#ZTAB[@]} + +echo 'Creating '${ZCONF}'/WORK = '${ZTAB[*]}' for '${ZCONF} + +[ ! -d ${ZCONF}/MY_SRC ] && \mkdir ${ZCONF}/MY_SRC +[ -d ${ZCONF}/WORK ] || \mkdir ${ZCONF}/WORK + +if [ "${ZSRC}" != 'none' ] ; then + + if [ -d ${ZSRC} ] ; then + ln -sf ${ZSRC}/*.[Ffh]90 ${ZCONF}/MY_SRC/. + echo 'MY_SRC content is linked to '${ZSRC} + else + echo 'External directory for MY_SRC does not exist. Using default.' + fi + +else + echo 'MY_SRC directory is : '${ZCONF}'/MY_SRC' +fi + +#\rm -f ../${1}/WORK/* + +for comp in ${ZTAB[*]}; do + find ${NEMO_DIR}/$comp -name *.[Ffh]90 -exec ln -sf {} ${ZCONF}/WORK \; +done + +for i in `(cd ${ZCONF}/MY_SRC ; \ls *.[Ffh]90 2>/dev/null ) `; do + [ -f ${ZCONF}/MY_SRC/$i ] && ln -sf $PWD/${ZCONF}/MY_SRC/${i} ${ZCONF}/WORK/. +done + +unset -v ZCONF ZTAB i NDIR diff --git a/NEMO_4.0.4_surge/mk/Fmake_bld.sh b/NEMO_4.0.4_surge/mk/Fmake_bld.sh new file mode 100755 index 0000000..53d9f7e --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fmake_bld.sh @@ -0,0 +1,64 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ============ +# Fmake_bld.sh +# ============ +# +# -------------------- +# Make build directory +# -------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fmake_bld.sh +# +# +# DESCRIPTION +# =========== +# +# +# Under CONFIG_NAME : +# - Make the build directory +# - Create repositories needed : +# - BLD for compilation +# +# A tmpdir can be specified for memory issues. +# +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fmake_bld.sh NEMOGCM/cfgs GYRE /usr/tmp +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fmake_bld.sh 9651 2018-05-28 06:47:14Z nicolasmartin $ +# +# +# +# * creation +# +#- +[ ! -d ${3}/${2} ] && \mkdir ${3}/${2} +[ ! -d ${3}/${2}/BLD ] && \mkdir ${3}/${2}/BLD +[ ! -d ${1}/${2}/BLD ] && ln -sf ${3}/${2}/BLD ${1}/${2}/BLD +[ -f ${1}/${NEW_CONF}/cpp_${NEW_CONF}.fcm ] && ln -sf ${1}/${NEW_CONF}/cpp_${NEW_CONF}.fcm ${COMPIL_DIR}/cpp.fcm +rm -f ${1}/${NEW_CONF}/BLD/fcm.bld.lock diff --git a/NEMO_4.0.4_surge/mk/Fmake_config.sh b/NEMO_4.0.4_surge/mk/Fmake_config.sh new file mode 100755 index 0000000..12babc4 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fmake_config.sh @@ -0,0 +1,66 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# =============== +# Fmake_config.sh +# =============== +# +# --------------- +# Make the config +# --------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fmake_config.sh +# +# +# DESCRIPTION +# =========== +# +# +# - Make the config directory +# - Create repositories needed : +# +# - EXP00 for namelist +# - MY_SRC for user sources +# - BLD for compilation +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fmake_config.sh CONFIG_NAME REF_CONFIG_NAME +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fmake_config.sh 9719 2018-05-31 15:57:27Z nicolasmartin $ +# +# +# +# * creation +# +#- +\mkdir -p ${1} +\mkdir -p ${1}/EXP00 +\mkdir -p ${1}/MY_SRC +\cp -R -n ${2}/cpp_${2}.fcm ${1}/cpp_${1}.fcm +\cp -R -n ${2}/EXPREF/*namelist* ${1}/EXP00/. +\cp -R -n ${2}/EXPREF/*.xml ${1}/EXP00/. +[ -f ${2}/EXPREF/AGRIF_FixedGrids.in ] && \cp -R -n ${2}/EXPREF/AGRIF_FixedGrids.in ${1}/EXP00/. +[ -d ${2}/MY_SRC ] && \cp -n ${2}/MY_SRC/* ${1}/MY_SRC/. 2> /dev/null diff --git a/NEMO_4.0.4_surge/mk/Fprep_agrif.sh b/NEMO_4.0.4_surge/mk/Fprep_agrif.sh new file mode 100755 index 0000000..f37b17f --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fprep_agrif.sh @@ -0,0 +1,79 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ============== +# Fprep_agrif.sh +# ============== +# +# --------------------- +# Preparation for AGRIF +# --------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fprep_agrif.sh +# +# +# DESCRIPTION +# =========== +# +# +# Prepare directories for AGRIF and copy files needed +# +# Compile the conv +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fprep_agrif.sh CONFIG_NAME +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fprep_agrif.sh 9598 2018-05-15 22:47:16Z nicolasmartin $ +# +# +# +# * creation +# +#- + +#- AGRIF conv +if [ "$AGRIFUSE" == 1 ]; then +#-MPI for AGRIF +if [ ! -f ${MAIN_DIR}/ext/AGRIF/nemo_mpi.h ];then + echo '#if defined key_mpp_mpi' > ${MAIN_DIR}/ext/AGRIF/nemo_mpi.h + echo '#define AGRIF_MPI' >> ${MAIN_DIR}/ext/AGRIF/nemo_mpi.h + echo '#endif' >> ${MAIN_DIR}/ext/AGRIF/nemo_mpi.h +fi + + #- CONV +fcm build ${COMPIL_DIR}/conv.cfg || exit 1 +#C_COMPILER=${CC-cc} +#gmake CC=${C_COMPILER} -C ${MAIN_DIR}/ext/AGRIF/LIB + +#- AGRIF sources +[ ! -d $2/$1/NEMOFILES ] && mkdir $2/$1/NEMOFILES +[ ! -d $2/$1/NEMOFILES/AGRIF_INC ] && mkdir $2/$1/NEMOFILES/AGRIF_INC +[ ! -d $2/$1/NEMOFILES/AGRIF_MODELFILES ] && mkdir $2/$1/NEMOFILES/AGRIF_MODELFILES +cp -f -r ${MAIN_DIR}/ext/AGRIF/agrif_oce.in $2/$1/NEMOFILES/ +#cp -f -r ${MAIN_DIR}/ext/AGRIF/conv $2/$1/NEMOFILES/ +cp -f -r $2/$1/AGRIFLIB/bin/conv $2/$1/NEMOFILES/ + +fi diff --git a/NEMO_4.0.4_surge/mk/Fread_dir.sh b/NEMO_4.0.4_surge/mk/Fread_dir.sh new file mode 100755 index 0000000..2e92921 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/Fread_dir.sh @@ -0,0 +1,83 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ============ +# Fread_dir.sh +# ============ +# +# --------------------- +# Read user directories +# --------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ Fread_dir.sh +# +# +# DESCRIPTION +# =========== +# +# +# Read directoires needed from standard input +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./Fread_dir.sh Directory_NAME YES/NO +# +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: Fread_dir.sh 3294 2012-01-28 16:44:18Z rblod $ +# +# +# +# * creation +# +#- + +if [ "$2" == "YES" ]; then + echo -n " $1 [Y/n] " + read answer + answer=`echo $answer | sed 's/^[yY].*$/y/'` + if [ -z "$answer" -o "x$answer" = "xy" ]; then + TAB[$ind]="$1" + let ind=ind+1 + echo " $1 selected " + echo " " + else + echo " $1 Not selected " + echo " " + fi + unset -v answer +else + echo -n " $1 [y/N] " + read answer + answer=`echo $answer | sed 's/^[nN].*$/N/'` + if [ "x$answer" = "xy" ]; then + TAB[$ind]="$1" + let ind=ind+1 + echo " $1 selected " + echo " " + else + echo " $1 Not selected " + echo " " + fi + unset -v answer +fi diff --git a/NEMO_4.0.4_surge/mk/README b/NEMO_4.0.4_surge/mk/README new file mode 100644 index 0000000..b54b12d --- /dev/null +++ b/NEMO_4.0.4_surge/mk/README @@ -0,0 +1,7 @@ +CSHRC : +setenv PATH ~/NEMOGCM/TOOLS:$PATH +setenv NEMO_TDIR /users/rblod/tmp + +BASH : +export PATH=$PATH:~/NEMOGCM/TOOLS' +export NEMO_TDIR=/users/rblod/tmp diff --git a/NEMO_4.0.4_surge/mk/agrifpp.sh b/NEMO_4.0.4_surge/mk/agrifpp.sh new file mode 100755 index 0000000..ca8f40b --- /dev/null +++ b/NEMO_4.0.4_surge/mk/agrifpp.sh @@ -0,0 +1,62 @@ +#!/bin/bash +#set -x +set -o posix +#set -u +#set -e +#+ +# +# ========== +# agrifpp.sh +# ========== +# +# ---------------------------- +# Preform AGrif pre-processing +# ---------------------------- +# +# SYNOPSIS +# ======== +# +# :: +# +# $ agrifpp.sh +# +# +# DESCRIPTION +# =========== +# +# +# Preprocess file using the conv in NEMOFILES directory +# Standard preprocessed files are stored in NEMOFILES/ppsrc/nemo +# Source files are stored under NEMOFILES/obj +# Include filess in NEMOFILES/inc +# Note that agrif2model.F90 should not be preprocess (standard one) +# +# EXAMPLES +# ======== +# +# :: +# +# $ ./agrifpp.sh FILE_TO_PROCESS +# +# TODO +# ==== +# +# option debug +# +# +# EVOLUTIONS +# ========== +# +# $Id: agrifpp.sh 2143 2010-10-04 12:49:55Z rblod $ +# +# +# +# * creation +# +#- +MYFILE=$(basename "$1") +if [ "$MYFILE" == "agrif2model.f90" ];then + \cp ${NEMO_TDIR}/${NEW_CONF}/WORK/${MYFILE/.f90/.F90} ${NEMO_TDIR}/${NEW_CONF}/NEMOFILES/obj/$MYFILE +else +cd ${NEMO_TDIR}/${NEW_CONF}/NEMOFILES/ppsrc/nemo ; ${NEMO_TDIR}/${NEW_CONF}/NEMOFILES/conv ${NEMO_TDIR}/${NEW_CONF}/NEMOFILES/agrif_oce.in -rm -incdir ${NEMO_TDIR}/${NEW_CONF}/NEMOFILES/inc -comdirout ${NEMO_TDIR}/${NEW_CONF}/NEMOFILES/obj -convfile ${MYFILE} > /dev/null +fi \ No newline at end of file diff --git a/NEMO_4.0.4_surge/mk/arch.history b/NEMO_4.0.4_surge/mk/arch.history new file mode 100644 index 0000000..fea20c4 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/arch.history @@ -0,0 +1 @@ +/work/n01/n01/jelt/AMM7_SURGE/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Cray_4.2.fcm diff --git a/NEMO_4.0.4_surge/mk/arch_nemo.fcm b/NEMO_4.0.4_surge/mk/arch_nemo.fcm new file mode 100644 index 0000000..8e072b6 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/arch_nemo.fcm @@ -0,0 +1,69 @@ + +#========================================================== +# Automatically generated by Fcheck_archfile.sh from +# /work/n01/n01/jelt/AMM7_SURGE/NEMO_4.0.4_surge/arch/NOC/arch-X86_ARCHER2-Cray_4.2.fcm +#========================================================== + +# compiler options for Archer CRAY XC-30 (using crayftn compiler) +# +# NCDF_HOME root directory containing lib and include subdirectories for netcdf4 +# HDF5_HOME root directory containing lib and include subdirectories for HDF5 +# XIOS_HOME root directory containing lib for XIOS +# OASIS_HOME root directory containing lib for OASIS +# +# NCDF_INC netcdf4 include file +# NCDF_LIB netcdf4 library +# XIOS_INC xios include file (taken into accound only if key_xios is activated) +# XIOS_LIB xios library (taken into accound only if key_xios is activated) +# OASIS_INC oasis include file (taken into accound only if key_oasis3 is activated) +# OASIS_LIB oasis library (taken into accound only if key_oasis3 is activated) +# +# FC Fortran compiler command +# FCFLAGS Fortran compiler flags +# FFLAGS Fortran 77 compiler flags +# LD linker +# LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries +# FPPFLAGS pre-processing flags +# AR assembler +# ARFLAGS assembler flags +# MK make +# USER_INC complete list of include files +# USER_LIB complete list of libraries to pass to the linker +# CC C compiler used to compile conv for AGRIF +# CFLAGS compiler flags used with CC +# +# Note that: +# - unix variables $... are accpeted and will be evaluated before calling fcm. +# - fcm variables are starting with a % (and not a $) +# +# Known to work with: module load cray-mpich/8.1.23 ; module load cray-hdf5-parallel/1.12.2.1 ; module load cray-netcdf-hdf5parallel/4.9.0.1 +%NCDF_HOME /opt/cray/pe/netcdf-hdf5parallel/4.9.0.1/crayclang/14.0 +%HDF5_HOME /opt/cray/pe/hdf5-parallel/1.12.2.1/crayclang/14.0 +%XIOS_HOME /work/n01/shared/nemo/XIOS2_Cray +#OASIS_HOME + +%NCDF_INC -I%NCDF_HOME/include -I%HDF5_HOME/include +%NCDF_LIB -L%HDF5_HOME/lib -L%NCDF_HOME/lib -lnetcdff -lnetcdf -lhdf5_hl -lhdf5 -lz +%XIOS_INC -I%XIOS_HOME/inc +%XIOS_LIB -L%XIOS_HOME/lib -lxios +#OASIS_INC -I%OASIS_HOME/build/lib/mct -I%OASIS_HOME/build/lib/psmile.MPI1 +#OASIS_LIB -L%OASIS_HOME/lib -lpsmile.MPI1 -lmct -lmpeu -lscrip + +%CPP cpp -Dkey_nosignedzero +%FC ftn +%FCFLAGS -em -s integer32 -s real64 -O1,vector0 -hflex_mp=intolerant -N1023 -M878 +%FFLAGS -em -s integer32 -s real64 -O1,vector0 -hflex_mp=intolerant -N1023 -M878 +%LD CC -Wl,--allow-multiple-definition +%FPPFLAGS -P -traditional +%LDFLAGS -lmpifort_cray +%AR ar +%ARFLAGS -r +%MK gmake +%USER_INC %XIOS_INC %NCDF_INC +%USER_LIB %XIOS_LIB %NCDF_LIB +#USER_INC %XIOS_INC %OASIS_INC %NCDF_INC +#USER_LIB %XIOS_LIB %OASIS_LIB %NCDF_LIB + +%CC cc -Wl,--allow-multiple-definition +%CFLAGS -O0 +bld::tool::fc_modsearch -J diff --git a/NEMO_4.0.4_surge/mk/bld.cfg b/NEMO_4.0.4_surge/mk/bld.cfg new file mode 100644 index 0000000..d0ab819 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/bld.cfg @@ -0,0 +1,68 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +inc $COMPIL_DIR/arch_nemo.fcm +inc $COMPIL_DIR/cpp.fcm + +search_src 1 + +src::ioipsl $MAIN_DIR/ext/IOIPSL/src +src::agrif $MAIN_DIR/ext/AGRIF/AGRIF_FILES +src::nemo $CONFIG_DIR/$NEW_CONF/NEMOFILES/obj + +bld::target nemo.exe +bld::exe_dep + + +dir::root $NEMO_TDIR/$NEW_CONF/BLD + + +bld::tool::cpp %CPP +bld::tool::fpp %CPP +bld::tool::fc %FC +bld::tool::fflags %FCFLAGS %USER_INC +bld::tool::fflags::agrif %FFLAGS %USER_INC +bld::tool::ld %LD +bld::tool::ldflags %LDFLAGS %USER_LIB +bld::tool::ar %AR +bld::tool::arflags %ARFLAGS +bld::tool::make %MK + +# Pre-process code before analysing dependencies +bld::pp::ioipsl 1 +bld::pp::nemo 1 +bld::pp::agrif 1 +bld::tool::fppflags::nemo %FPPFLAGS -I$CONFIG_DIR/$NEW_CONF/NEMOFILES/inc +bld::tool::fppflags::ioipsl %FPPFLAGS +bld::tool::fppflags::agrif %FPPFLAGS -include ${MAIN_DIR}/ext/AGRIF/nemo_mpi.h + +# 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 +# Don't generate interface files +bld::tool::geninterface none + +# Allow ".h90" as an extension for CPP include files +bld::infile_ext::h90 CPP::INCLUDE +bld::infile_ext::f90 FPP::FPP9X::SOURCE + +# extension for module output +bld::outfile_ext::mod .mod + +# rename executable to nemo.exe +bld::exe_name::model nemo.exe diff --git a/NEMO_4.0.4_surge/mk/bld_preproagr.cfg b/NEMO_4.0.4_surge/mk/bld_preproagr.cfg new file mode 100644 index 0000000..0ca69a1 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/bld_preproagr.cfg @@ -0,0 +1,82 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +inc $COMPIL_DIR/arch_nemo.fcm +inc $COMPIL_DIR/cpp.fcm +search_src 1 + +src::nemo $CONFIG_DIR/$NEW_CONF/WORK + +bld::target lib_cray.f90 nemo.f90 agrif_user.f90 agrif2model.f90 + +dir::root $NEMO_TDIR/$NEW_CONF/NEMOFILES + +bld::tool::fc_output +bld::tool::fc_compile +bld::tool::fc_include +bld::tool::fc $COMPIL_DIR/agrifpp.sh +bld::tool::fflags +bld::tool::ld +bld::tool::ldflags +bld::tool::ar +bld::tool::arflags +bld::tool::make %MK + +OUTFILE_EXT::obj .f90 + +# Pre-process code before analysing dependencies +bld::pp::nemo 1 +bld::pp::nemo/agrif2model 0 +bld::tool::cpp %CPP +bld::tool::fpp %CPP +bld::tool::fppflags::nemo %FPPFLAGS + +# Ignore the following dependencies +bld::excl_dep inc::netcdf.inc +bld::excl_dep inc::VT.inc +bld::excl_dep use::netcdf +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::nc4interface +bld::excl_dep use::ioipsl +bld::excl_dep use::xios +bld::excl_dep use::agrif_grids +bld::excl_dep use::agrif_types +bld::excl_dep use::agrif_util +bld::excl_dep inc::SetNumberofcells.h +bld::excl_dep inc::GetNumberofcells.h +bld::excl_dep inc::include_use_Alloc_agrif.h +bld::excl_dep inc::allocations_calls_agrif.h +bld::excl_dep inc::modtype_agrif.h +bld::excl_dep inc::probdim_agrif.h +bld::excl_dep inc::keys_agrif.h +bld::excl_dep h::SetNumberofcells.h +bld::excl_dep h::GetNumberofcells.h +bld::excl_dep h::include_use_Alloc_agrif.h +bld::excl_dep h::allocations_calls_agrif.h +bld::excl_dep h::modtype_agrif.h +bld::excl_dep h::probdim_agrif.h +bld::excl_dep h::keys_agrif.h +bld::excl_dep use::mod_attribut +bld::excl_dep use::mod_event_client +bld::excl_dep use::mod_ioclient +#bld::excl_dep OBJ + +# Don't generate interface files +bld::tool::geninterface none + +# Allow ".h90" and ".f90" as an extension for CPP include files +bld::infile_ext::h90 CPP::INCLUDE +bld::infile_ext::f90 FPP::FPP9X::SOURCE +bld::src_type::nemo/agrif2model.F90 FORTRAN::FORTRAN9X::SOURCE diff --git a/NEMO_4.0.4_surge/mk/bld_tools.cfg b/NEMO_4.0.4_surge/mk/bld_tools.cfg new file mode 100644 index 0000000..e08e4d3 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/bld_tools.cfg @@ -0,0 +1,48 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +inc $COMPIL_DIR/arch_tools.fcm + +search_src 1 + +src::nemo $TOOLS_DIR/$NEW_CONF/src + +dir::root $NEMO_TDIR/$NEW_CONF/BLD + +bld::tool::cpp %CPP +bld::tool::fpp %CPP +bld::tool::fc %FC +bld::tool::fflags %FCFLAGS %USER_INC +bld::tool::ld %LD +bld::tool::ldflags %LDFLAGS %USER_LIB +bld::tool::ar %AR +bld::tool::arflags %ARFLAGS +bld::tool::make %MK + +# Ignore the following dependencies +bld::excl_dep inc::netcdf.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 use::mpi +bld::excl_dep use::mod_oasis + +# 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 diff --git a/NEMO_4.0.4_surge/mk/bldxag.cfg b/NEMO_4.0.4_surge/mk/bldxag.cfg new file mode 100644 index 0000000..5098a15 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/bldxag.cfg @@ -0,0 +1,64 @@ +# ----------------------- FCM extract configuration file ----------------------- +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ + +inc $COMPIL_DIR/arch_nemo.fcm +inc $COMPIL_DIR/cpp.fcm + +search_src 1 + +src::ioipsl $MAIN_DIR/ext/IOIPSL/src +src::nemo $CONFIG_DIR/$NEW_CONF/WORK + +bld::target nemo.exe +bld::exe_dep + + +dir::root $NEMO_TDIR/$NEW_CONF/BLD + + +bld::tool::cpp %CPP +bld::tool::fpp %CPP +bld::tool::fc %FC +bld::tool::fflags %FCFLAGS %USER_INC +bld::tool::ld %LD +bld::tool::ldflags %LDFLAGS %USER_LIB +bld::tool::ar %AR +bld::tool::arflags %ARFLAGS +bld::tool::make %MK + +# Pre-process code before analysing dependencies +bld::pp::ioipsl 1 +bld::pp::nemo 1 +bld::tool::fppflags::nemo %FPPFLAGS +bld::tool::fppflags::ioipsl %FPPFLAGS + +# 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 +# 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 + diff --git a/NEMO_4.0.4_surge/mk/conv.cfg b/NEMO_4.0.4_surge/mk/conv.cfg new file mode 100644 index 0000000..f281105 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/conv.cfg @@ -0,0 +1,35 @@ +# ----------------------- FCM extract configuration file ----------------------- +# template to compile agrif conv, currently not used +cfg::type bld +cfg::version 1.0 + + +# ------------------------------------------------------------------------------ +# Build information +# ------------------------------------------------------------------------------ +inc $COMPIL_DIR/arch_nemo.fcm + +bld::tool::cc %CC +bld::tool::cflags %CFLAGS +bld::tool::make %MK + +src::convsrc $MAIN_DIR/ext/AGRIF/LIB + + #---------------------------------------------------------------------------- +# Build options (code-specific, machine-independent) +# ---------------------------------------------------------------------------- +dir::root $NEMO_TDIR/$NEW_CONF/AGRIFLIB + +#bld::tool::cflags::convsrc -O0 +#bld::tool::ld::convsrc cc +#bld::tool::ldflags::convsrc -O ../obj/fortran.o ../obj/fortran.o +#bld::pp 1 + + + +bld::exe_name::main conv +bld::target libconvsrc.a fortran.o main.o conv +bld::exe_dep::conv + + + diff --git a/NEMO_4.0.4_surge/mk/cpp.fcm b/NEMO_4.0.4_surge/mk/cpp.fcm new file mode 100644 index 0000000..29ac2dd --- /dev/null +++ b/NEMO_4.0.4_surge/mk/cpp.fcm @@ -0,0 +1 @@ + bld::tool::fppkeys key_diainstant key_mpp_mpi key_iomput key_nosignedzero diff --git a/NEMO_4.0.4_surge/mk/cpp.history b/NEMO_4.0.4_surge/mk/cpp.history new file mode 100644 index 0000000..1990b1c --- /dev/null +++ b/NEMO_4.0.4_surge/mk/cpp.history @@ -0,0 +1 @@ +/work/n01/n01/jelt/AMM7_SURGE/NEMO_4.0.4_surge/cfgs/AMM7_SURGE/cpp_AMM7_SURGE.fcm diff --git a/NEMO_4.0.4_surge/mk/full_key_list.txt b/NEMO_4.0.4_surge/mk/full_key_list.txt new file mode 100644 index 0000000..dfb1793 --- /dev/null +++ b/NEMO_4.0.4_surge/mk/full_key_list.txt @@ -0,0 +1,23 @@ +key_agrif +key_asminc +key_c1d +key_cice +key_cice4 +key_cyclone +key_diaar5 +key_diahth +key_diainstant +key_iomput +key_mpi2 +key_mpp_mpi +key_nemocice_decomp +key_netcdf4 +key_nosignedzero +key_oa3mct_v1v2 +key_oasis3 +key_si3 +key_top +key_trdmxl_trc +key_trdtrc +key_vectopt_loop +key_xios25 diff --git a/NEMO_4.0.4_surge/mk/tools.txt b/NEMO_4.0.4_surge/mk/tools.txt new file mode 100644 index 0000000..a6cb4ae --- /dev/null +++ b/NEMO_4.0.4_surge/mk/tools.txt @@ -0,0 +1 @@ +DOMAINcfg diff --git a/NEMO_4.0.4_surge/src/OCE/ASM/asmbkg.F90 b/NEMO_4.0.4_surge/src/OCE/ASM/asmbkg.F90 new file mode 100644 index 0000000..48b12ca --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ASM/asmbkg.F90 @@ -0,0 +1,160 @@ +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 + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE asmpar ! Parameters for the assmilation interface + USE zdfmxl ! mixed layer depth +#if defined key_si3 + USE ice +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC asm_bkg_wri !: Write out the background state + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE asm_bkg_wri( kt ) + !!----------------------------------------------------------------------- + !! *** 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 + ! + 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( 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' , un ) + CALL iom_rstput( kt, nitbkg_r, inum, 'vn' , vn ) + CALL iom_rstput( kt, nitbkg_r, inum, 'tn' , tsn(:,:,:,jp_tem) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'sn' , tsn(:,:,:,jp_sal) ) + CALL iom_rstput( kt, nitbkg_r, inum, 'sshn' , sshn ) + 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' , un ) + CALL iom_rstput( kt, nitdin_r, inum, 'vn' , vn ) + CALL iom_rstput( kt, nitdin_r, inum, 'tn' , tsn(:,:,:,jp_tem) ) + CALL iom_rstput( kt, nitdin_r, inum, 'sn' , tsn(:,:,:,jp_sal) ) + CALL iom_rstput( kt, nitdin_r, inum, 'sshn' , sshn ) +#if defined key_si3 + IF( nn_ice == 2 ) THEN + IF( ALLOCATED(at_i) ) THEN + CALL iom_rstput( kt, nitdin_r, inum, 'iceconc', at_i(:,:) ) + ELSE + CALL ctl_warn('asm_bkg_wri: Ice concentration not written to background ', & + & 'as ice variable at_i not allocated on this timestep') + ENDIF + ENDIF +#endif + ! + CALL iom_close( inum ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE asm_bkg_wri + + !!====================================================================== +END MODULE asmbkg diff --git a/NEMO_4.0.4_surge/src/OCE/ASM/asminc.F90 b/NEMO_4.0.4_surge/src/OCE/ASM/asminc.F90 new file mode 100644 index 0000000..d6b916b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ASM/asminc.F90 @@ -0,0 +1,1020 @@ +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 +#if defined key_si3 + USE ice , ONLY : hm_i, at_i, at_i_b +#endif + ! + 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 + +#if defined key_asminc + LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .TRUE. !: Logical switch for assimilation increment interface +#else + LOGICAL, PUBLIC, PARAMETER :: lk_asminc = .FALSE. !: No assimilation increments +#endif + 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 +#if defined key_asminc + REAL(wp), PUBLIC, DIMENSION(:,:) , ALLOCATABLE :: ssh_iau !: IAU-weighted sea surface height increment +#endif + ! !!! 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 +#if defined key_cice && defined key_asminc + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ndaice_da ! ice increment tendency into CICE +#endif + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE asm_inc_init + !!---------------------------------------------------------------------- + !! *** ROUTINE asm_inc_init *** + !! + !! ** Purpose : Initialize the assimilation increment and IAU weights. + !! + !! ** Method : Initialize the assimilation increment and IAU weights. + !! + !! ** Action : + !!---------------------------------------------------------------------- + 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=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(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. + + REWIND( numnam_ref ) ! Namelist nam_asminc in reference namelist : Assimilation increment + READ ( numnam_ref, nam_asminc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_asminc in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist nam_asminc in configuration namelist : Assimilation increment + 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 defined key_asminc + ALLOCATE( ssh_iau (jpi,jpj) ) ; ssh_iau (:,:) = 0._wp +#endif +#if defined key_cice && defined key_asminc + ALLOCATE( ndaice_da (jpi,jpj) ) ; ndaice_da (:,:) = 0._wp +#endif + ! + 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_autoglo, 'bckint', t_bkginc, 1 ) + CALL iom_get( inum, jpdom_autoglo, '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_autoglo, 'bckinu', u_bkginc, 1 ) + CALL iom_get( inum, jpdom_autoglo, '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_autoglo, '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_autoglo, '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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zhdiv(ji,jj) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * u_bkginc(ji ,jj,jk) & + & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * u_bkginc(ji-1,jj,jk) & + & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * v_bkginc(ji,jj ,jk) & + & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * v_bkginc(ji,jj-1,jk) ) / e3t_n(ji,jj,jk) + END DO + END DO + CALL lbc_lnk( 'asminc', zhdiv, 'T', 1. ) ! lateral boundary cond. (no sign change) + ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_autoglo, 'tn', t_bkg ) + CALL iom_get( inum, jpdom_autoglo, 'sn', s_bkg ) + t_bkg(:,:,:) = t_bkg(:,:,:) * tmask(:,:,:) + s_bkg(:,:,:) = s_bkg(:,:,:) * tmask(:,:,:) + ENDIF + ! + IF ( ln_dyninc ) THEN + CALL iom_get( inum, jpdom_autoglo, 'un', u_bkg ) + CALL iom_get( inum, jpdom_autoglo, 'vn', v_bkg ) + u_bkg(:,:,:) = u_bkg(:,:,:) * umask(:,:,:) + v_bkg(:,:,:) = v_bkg(:,:,:) * vmask(:,:,:) + ENDIF + ! + IF ( ln_sshinc ) THEN + CALL iom_get( inum, jpdom_autoglo, 'sshn', ssh_bkg ) + ssh_bkg(:,:) = ssh_bkg(:,:) * tmask(:,:,1) + ENDIF + ! + CALL iom_close( inum ) + ! + ENDIF + ! + IF(lwp) WRITE(numout,*) ' ==>>> Euler time step switch is ', neuler + ! + IF( lk_asminc ) THEN !== data assimilation ==! + IF( ln_bkgwri ) CALL asm_bkg_wri( nit000 - 1 ) ! Output background fields + IF( ln_asmdin ) THEN ! Direct initialization + IF( ln_trainc ) CALL tra_asm_inc( nit000 - 1 ) ! Tracers + IF( ln_dyninc ) CALL dyn_asm_inc( nit000 - 1 ) ! Dynamics + IF( ln_sshinc ) CALL ssh_asm_inc( nit000 - 1 ) ! SSH + ENDIF + ENDIF + ! + END SUBROUTINE asm_inc_init + + + SUBROUTINE tra_asm_inc( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk + INTEGER :: it + REAL(wp) :: zincwgt ! IAU weight for current time step + REAL (wp), DIMENSION(jpi,jpj,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 + DO jk = 1, jpkm1 + CALL eos_fzp( tsn(:,:,jk,jp_sal), fzptnz(:,:,jk), gdept_n(:,:,jk) ) + END DO + ! + ! !-------------------------------------- + IF ( ln_asmiau ) THEN ! Incremental Analysis Updating + ! !-------------------------------------- + ! + IF ( ( kt >= nitiaustr_r ).AND.( kt <= nitiaufin_r ) ) THEN + ! + it = kt - nit000 + 1 + zincwgt = wgtiau(it) / rdt ! IAU weight for the current time step + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'tra_asm_inc : Tracer IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + 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(:,:,jk) > 0.0_wp .OR. & + & tsn(:,:,jk,jp_tem) + tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * wgtiau(it) > fzptnz(:,:,jk) ) + tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt + END WHERE + ELSE + tsa(:,:,jk,jp_tem) = tsa(:,:,jk,jp_tem) + t_bkginc(:,:,jk) * zincwgt + ENDIF + IF (ln_salfix) THEN + ! Do not apply negative increments if the salinity will fall below a specified + ! minimum value salfixmin + WHERE(s_bkginc(:,:,jk) > 0.0_wp .OR. & + & tsn(:,:,jk,jp_sal) + tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * wgtiau(it) > salfixmin ) + tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt + END WHERE + ELSE + tsa(:,:,jk,jp_sal) = tsa(:,:,jk,jp_sal) + s_bkginc(:,:,jk) * zincwgt + ENDIF + END DO + ! + ENDIF + ! + IF ( kt == nitiaufin_r + 1 ) THEN ! For bias crcn to work + DEALLOCATE( t_bkginc ) + DEALLOCATE( s_bkginc ) + ENDIF + ! !-------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !-------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + neuler = 0 ! 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. tsn(:,:,:,jp_tem) + t_bkginc(:,:,:) > fzptnz(:,:,:) ) + tsn(:,:,:,jp_tem) = t_bkg(:,:,:) + t_bkginc(:,:,:) + END WHERE + ELSE + tsn(:,:,:,jp_tem) = 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. tsn(:,:,:,jp_sal) + s_bkginc(:,:,:) > salfixmin ) + tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:) + END WHERE + ELSE + tsn(:,:,:,jp_sal) = s_bkg(:,:,:) + s_bkginc(:,:,:) + ENDIF + + tsb(:,:,:,:) = tsn(:,:,:,:) ! Update before fields + + CALL eos( tsb, rhd, rhop, gdept_0(:,:,:) ) ! Before potential and in situ densities +!!gm fabien +! CALL eos( tsb, rhd, rhop ) ! Before potential and in situ densities +!!gm + + IF( ln_zps .AND. .NOT. lk_c1d .AND. .NOT. ln_isfcav) & + & CALL zps_hde ( kt, jpts, tsb, gtsu, gtsv, & ! Partial steps: before horizontal gradient + & rhd, gru , grv ) ! of t, s, rd at the last ocean level + IF( ln_zps .AND. .NOT. lk_c1d .AND. ln_isfcav) & + & CALL zps_hde_isf( nit000, jpts, tsb, 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 ) + !!---------------------------------------------------------------------- + !! *** 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 ! Current time step + ! + INTEGER :: 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) / rdt ! IAU weight for the current time step + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_asm_inc : Dynamics IAU at time step = ', kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ! Update the dynamic tendencies + DO jk = 1, jpkm1 + ua(:,:,jk) = ua(:,:,jk) + u_bkginc(:,:,jk) * zincwgt + va(:,:,jk) = va(:,:,jk) + v_bkginc(:,:,jk) * zincwgt + END DO + ! + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( u_bkginc ) + DEALLOCATE( v_bkginc ) + ENDIF + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + neuler = 0 ! Force Euler forward step + ! + ! Initialize the now fields with the background + increment + un(:,:,:) = u_bkg(:,:,:) + u_bkginc(:,:,:) + vn(:,:,:) = v_bkg(:,:,:) + v_bkginc(:,:,:) + ! + ub(:,:,:) = un(:,:,:) ! Update before fields + vb(:,:,:) = vn(:,:,:) + ! + DEALLOCATE( u_bkg ) + DEALLOCATE( v_bkg ) + DEALLOCATE( u_bkginc ) + DEALLOCATE( v_bkginc ) + ENDIF + ! + ENDIF + ! + END SUBROUTINE dyn_asm_inc + + + SUBROUTINE ssh_asm_inc( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: it + INTEGER :: 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) / rdt ! IAU weight for the current time step + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'ssh_asm_inc : SSH IAU at time step = ', & + & kt,' with IAU weight = ', wgtiau(it) + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ! Save the tendency associated with the IAU weighted SSH increment + ! (applied in dynspg.*) +#if defined key_asminc + ssh_iau(:,:) = ssh_bkginc(:,:) * zincwgt +#endif + ! + ELSE IF( kt == nitiaufin_r+1 ) THEN + ! + ! test on ssh_bkginc needed as ssh_asm_inc is called twice by time step + IF (ALLOCATED(ssh_bkginc)) DEALLOCATE( ssh_bkginc ) + ! +#if defined key_asminc + ssh_iau(:,:) = 0._wp +#endif + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + neuler = 0 ! Force Euler forward step + ! + sshn(:,:) = ssh_bkg(:,:) + ssh_bkginc(:,:) ! Initialize the now fields the background + increment + ! + sshb(:,:) = sshn(:,:) ! Update before fields + e3t_b(:,:,:) = e3t_n(:,:,:) +!!gm why not e3u_b, e3v_b, gdept_b ???? + ! + DEALLOCATE( ssh_bkg ) + DEALLOCATE( ssh_bkginc ) + ! + ENDIF + ! + ENDIF + ! + END SUBROUTINE ssh_asm_inc + + + SUBROUTINE ssh_asm_div( kt, 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 + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: jk ! dummy loop index + REAL(wp), DIMENSION(:,:) , POINTER :: ztim ! local array + !!---------------------------------------------------------------------- + ! +#if defined key_asminc + CALL ssh_asm_inc( kt ) !== (calculate increments) + ! + IF( ln_linssh ) THEN + phdivn(:,:,1) = phdivn(:,:,1) - ssh_iau(:,:) / e3t_n(:,:,1) * tmask(:,:,1) + ELSE + ALLOCATE( ztim(jpi,jpj) ) + ztim(:,:) = ssh_iau(:,:) / ( ht_n(:,:) + 1.0 - ssmask(:,:) ) + DO jk = 1, jpkm1 + phdivn(:,:,jk) = phdivn(:,:,jk) - ztim(:,:) * tmask(:,:,jk) + END DO + ! + DEALLOCATE(ztim) + ENDIF +#endif + ! + 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 :: it + REAL(wp) :: zincwgt ! IAU weight for current time step +#if defined key_si3 + REAL(wp), DIMENSION(jpi,jpj) :: zofrld, zohicif, zseaicendg, zhicifinc + REAL(wp) :: zhicifmin = 0.5_wp ! ice minimum depth in metres +#endif + !!---------------------------------------------------------------------- + ! + ! !----------------------------------------- + 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 rdt (as with the tracer and other increments) + ! + 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 + ! + ! Sea-ice : SI3 case + ! +#if defined key_si3 + zofrld (:,:) = 1._wp - at_i(:,:) + zohicif(:,:) = hm_i(:,:) + ! + at_i (:,:) = 1. - MIN( MAX( 1.-at_i (:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) + at_i_b(:,:) = 1. - MIN( MAX( 1.-at_i_b(:,:) - seaice_bkginc(:,:) * zincwgt, 0.0_wp), 1.0_wp) + fr_i(:,:) = at_i(:,:) ! adjust ice fraction + ! + zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied + ! + ! Nudge sea ice depth to bring it up to a required minimum depth + WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) + zhicifinc(:,:) = (zhicifmin - hm_i(:,:)) * zincwgt + ELSEWHERE + zhicifinc(:,:) = 0.0_wp + END WHERE + ! + ! nudge ice depth + hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) + ! + ! seaice salinity balancing (to add) +#endif + ! +#if defined key_cice && defined key_asminc + ! Sea-ice : CICE case. Pass ice increment tendency into CICE + ndaice_da(:,:) = seaice_bkginc(:,:) * zincwgt / rdt +#endif + ! + IF ( kt == nitiaufin_r ) THEN + DEALLOCATE( seaice_bkginc ) + ENDIF + ! + ELSE + ! +#if defined key_cice && defined key_asminc + ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE +#endif + ! + ENDIF + ! !----------------------------------------- + ELSEIF ( ln_asmdin ) THEN ! Direct Initialization + ! !----------------------------------------- + ! + IF ( kt == nitdin_r ) THEN + ! + neuler = 0 ! Force Euler forward step + ! + ! Sea-ice : SI3 case + ! +#if defined key_si3 + zofrld (:,:) = 1._wp - at_i(:,:) + zohicif(:,:) = hm_i(:,:) + ! + ! Initialize the now fields the background + increment + at_i(:,:) = 1. - MIN( MAX( 1.-at_i(:,:) - seaice_bkginc(:,:), 0.0_wp), 1.0_wp) + at_i_b(:,:) = at_i(:,:) + fr_i(:,:) = at_i(:,:) ! adjust ice fraction + ! + zseaicendg(:,:) = zofrld(:,:) - (1. - at_i(:,:)) ! find out actual sea ice nudge applied + ! + ! Nudge sea ice depth to bring it up to a required minimum depth + WHERE( zseaicendg(:,:) > 0.0_wp .AND. hm_i(:,:) < zhicifmin ) + zhicifinc(:,:) = zhicifmin - hm_i(:,:) + ELSEWHERE + zhicifinc(:,:) = 0.0_wp + END WHERE + ! + ! nudge ice depth + hm_i (:,:) = hm_i (:,:) + zhicifinc(:,:) + ! + ! seaice salinity balancing (to add) +#endif + ! +#if defined key_cice && defined key_asminc + ! Sea-ice : CICE case. Pass ice increment tendency into CICE + ndaice_da(:,:) = seaice_bkginc(:,:) / rdt +#endif + IF ( .NOT. PRESENT(kindic) ) THEN + DEALLOCATE( seaice_bkginc ) + END IF + ! + ELSE + ! +#if defined key_cice && defined key_asminc + ndaice_da(:,:) = 0._wp ! Sea-ice : CICE case. Zero ice increment tendency into CICE +#endif + ! + 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) )*rdt +! +! ! 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(ji,jj,jk)) .and. (mld < gdepw(ji,jj,jk+1))) THEN +! mld=gdepw(ji,jj,jk+1) +! 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/NEMO_4.0.4_surge/src/OCE/ASM/asmpar.F90 b/NEMO_4.0.4_surge/src/OCE/ASM/asmpar.F90 new file mode 100644 index 0000000..247aa9c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ASM/asmpar.F90 @@ -0,0 +1,29 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE asmpar diff --git a/NEMO_4.0.4_surge/src/OCE/BDY/bdy_oce.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdy_oce.F90 new file mode 100644 index 0000000..fce1473 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdy_oce.F90 @@ -0,0 +1,174 @@ +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 +#if defined key_top + CHARACTER(LEN=20) :: cn_obc !: type of boundary condition to apply + REAL(wp) :: rn_fac !: multiplicative scaling factor + REAL(wp), POINTER, DIMENSION(:,:) :: trc !: now field of the tracer + LOGICAL :: dmp !: obc damping term +#endif + 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_bdy !: mark needed communication for given boundary, grid and neighbour + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: lrecv_bdy !: when searching in any direction + 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 + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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/NEMO_4.0.4_surge/src/OCE/BDY/bdydta.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdydta.F90 new file mode 100644 index 0000000..f3f6c61 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdydta.F90 @@ -0,0 +1,726 @@ +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 sbctide ! Tidal forcing or not + USE bdy_oce ! ocean open boundary conditions + USE bdytides ! tidal forcing at boundaries +#if defined key_si3 + USE ice ! sea-ice variables + USE icevar ! redistribute ice input into categories +#endif + ! + 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 ! +#if ! defined key_si3 + INTEGER , PARAMETER :: jpl = 1 +#endif + +!$AGRIF_DO_NOT_TREAT + TYPE(FLD), PUBLIC, ALLOCATABLE, DIMENSION(:,:), TARGET :: bf ! structure of input fields (file informations, fields read) +!$AGRIF_END_DO_NOT_TREAT + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dta( kt, kit, kt_offset ) + !!---------------------------------------------------------------------- + !! *** 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), OPTIONAL :: kit ! subcycle time-step index (for timesplitting option) + INTEGER, INTENT(in), OPTIONAL :: kt_offset ! time offset in units of timesteps. NB. if kit + ! ! is present then units = subcycle timesteps. + ! ! kt_offset = 0 => get data at "now" time level + ! ! kt_offset = -1 => get data at "before" time level + ! ! kt_offset = +1 => get data at "after" time level + ! ! etc. + ! + INTEGER :: jbdy, jfld, jstart, jend, ib, jl ! dummy loop indices + INTEGER :: ii, ij, ik, igrd, ipl ! local integers + INTEGER, DIMENSION(jpbgrd) :: ilen1 + 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 .AND. .NOT.PRESENT(kit) ) 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) = sshn(ii,ij) * 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) = un_b(ii,ij) * 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) = vn_b(ii,ij) * 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) = ( un(ii,ij,ik) - un_b(ii,ij) ) * 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) = ( vn(ii,ij,ik) - vn_b(ii,ij) ) * 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) = tsn(ii,ij,ik,jp_tem) * tmask(ii,ij,ik) + dta_bdy(jbdy)%sal(ib,ik) = tsn(ii,ij,ik,jp_sal) * tmask(ii,ij,ik) + END DO + END DO + ENDIF + ENDIF + +#if defined key_si3 + IF( nn_ice_dta(jbdy) == 0 ) THEN ! set ice to initial values + IF( dta_bdy(jbdy)%lneed_ice ) THEN + igrd = 1 + DO jl = 1, jpl + DO ib = 1, idx_bdy(jbdy)%nblen(igrd) + ii = idx_bdy(jbdy)%nbi(ib,igrd) + ij = idx_bdy(jbdy)%nbj(ib,igrd) + dta_bdy(jbdy)%a_i(ib,jl) = a_i (ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%h_i(ib,jl) = h_i (ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%h_s(ib,jl) = h_s (ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%t_i(ib,jl) = SUM(t_i (ii,ij,:,jl)) * r1_nlay_i * tmask(ii,ij,1) + dta_bdy(jbdy)%t_s(ib,jl) = SUM(t_s (ii,ij,:,jl)) * r1_nlay_s * tmask(ii,ij,1) + dta_bdy(jbdy)%tsu(ib,jl) = t_su(ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%s_i(ib,jl) = s_i (ii,ij,jl) * tmask(ii,ij,1) + ! melt ponds + dta_bdy(jbdy)%aip(ib,jl) = a_ip(ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%hip(ib,jl) = h_ip(ii,ij,jl) * tmask(ii,ij,1) + dta_bdy(jbdy)%hil(ib,jl) = h_il(ii,ij,jl) * tmask(ii,ij,1) + END DO + END DO + ENDIF + 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 + ! ------------------------ + CALL fld_read( kt, 1, bf_alias, kit = kit, kt_offset = kt_offset ) + + ! 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_n(ii,ij,ik) * umask(ii,ij,ik) * dta_alias%u3d(ib,ik) + END DO + dta_alias%u2d(ib) = dta_alias%u2d(ib) * r1_hu_n(ii,ij) + 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 + 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_n(ii,ij,ik) * vmask(ii,ij,ik) * dta_alias%v3d(ib,ik) + END DO + dta_alias%v2d(ib) = dta_alias%v2d(ib) * r1_hv_n(ii,ij) + 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 + + ! update tidal harmonic forcing + IF( PRESENT(kit) .AND. nn_dyn2d_dta(jbdy) .GE. 2 ) THEN + CALL bdytide_update( kt = kt, idx = idx_bdy(jbdy), dta = dta_alias, td = tides(jbdy), & + & kit = kit, kt_offset = kt_offset ) + ENDIF + + ! atm surface pressure : add inverted barometer effect to ssh if it was read + IF ( ln_apr_obc ) 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 + +#if defined key_si3 + IF( dta_alias%lneed_ice .AND. idx_bdy(jbdy)%nblen(1) > 0 ) THEN + ! fill temperature and salinity arrays + IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_i)%fnow(:,1,:) = rice_tem (jbdy) + IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyt_s)%fnow(:,1,:) = rice_tem (jbdy) + IF( TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) bf_alias(jp_bdytsu)%fnow(:,1,:) = rice_tem (jbdy) + IF( TRIM(bf_alias(jp_bdys_i)%clrootname) == 'NOT USED' ) bf_alias(jp_bdys_i)%fnow(:,1,:) = rice_sal (jbdy) + IF( TRIM(bf_alias(jp_bdyaip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyaip)%fnow(:,1,:) = rice_apnd(jbdy) * & ! rice_apnd is the pond fraction + & bf_alias(jp_bdya_i)%fnow(:,1,:) ! ( a_ip = rice_apnd * a_i ) + IF( TRIM(bf_alias(jp_bdyhip)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhip)%fnow(:,1,:) = rice_hpnd(jbdy) + IF( TRIM(bf_alias(jp_bdyhil)%clrootname) == 'NOT USED' ) bf_alias(jp_bdyhil)%fnow(:,1,:) = rice_hlid(jbdy) + + ! if T_i is read and not T_su, set T_su = T_i + IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_i)%fnow(:,1,:) + ! if T_s is read and not T_su, set T_su = T_s + IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdytsu)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdytsu)%fnow(:,1,:) = bf_alias(jp_bdyt_s)%fnow(:,1,:) + ! if T_i is read and not T_s, set T_s = T_i + IF( TRIM(bf_alias(jp_bdyt_i)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdyt_i)%fnow(:,1,:) + ! if T_su is read and not T_s, set T_s = T_su + IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_s)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_s)%fnow(:,1,:) = bf_alias(jp_bdytsu)%fnow(:,1,:) + ! if T_su is read and not T_i, set T_i = (T_su + T_freeze)/2 + IF( TRIM(bf_alias(jp_bdytsu)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdytsu)%fnow(:,1,:) + 271.15 ) + ! if T_s is read and not T_i, set T_i = (T_s + T_freeze)/2 + IF( TRIM(bf_alias(jp_bdyt_s)%clrootname) /= 'NOT USED' .AND. TRIM(bf_alias(jp_bdyt_i)%clrootname) == 'NOT USED' ) & + & bf_alias(jp_bdyt_i)%fnow(:,1,:) = 0.5_wp * ( bf_alias(jp_bdyt_s)%fnow(:,1,:) + 271.15 ) + + ! make sure ponds = 0 if no ponds scheme + IF ( .NOT.ln_pnd ) THEN + bf_alias(jp_bdyaip)%fnow(:,1,:) = 0._wp + bf_alias(jp_bdyhip)%fnow(:,1,:) = 0._wp + bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp + ENDIF + IF ( .NOT.ln_pnd_lids ) THEN + bf_alias(jp_bdyhil)%fnow(:,1,:) = 0._wp + ENDIF + + ! convert N-cat fields (input) into jpl-cat (output) + ipl = SIZE(bf_alias(jp_bdya_i)%fnow, 3) + IF( ipl /= jpl ) THEN ! ice: convert N-cat fields (input) into jpl-cat (output) + CALL ice_var_itd( bf_alias(jp_bdyh_i)%fnow(:,1,:), bf_alias(jp_bdyh_s)%fnow(:,1,:), bf_alias(jp_bdya_i)%fnow(:,1,:), & ! in + & dta_alias%h_i , dta_alias%h_s , dta_alias%a_i , & ! out + & bf_alias(jp_bdyt_i)%fnow(:,1,:), bf_alias(jp_bdyt_s)%fnow(:,1,:), & ! in (optional) + & bf_alias(jp_bdytsu)%fnow(:,1,:), bf_alias(jp_bdys_i)%fnow(:,1,:), & ! in - + & bf_alias(jp_bdyaip)%fnow(:,1,:), bf_alias(jp_bdyhip)%fnow(:,1,:), bf_alias(jp_bdyhil)%fnow(:,1,:), & ! in - + & dta_alias%t_i , dta_alias%t_s , & ! out - + & dta_alias%tsu , dta_alias%s_i , & ! out - + & dta_alias%aip , dta_alias%hip , dta_alias%hil ) ! out - + ENDIF + ENDIF +#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( cn_dyn2d(jbdy) == 'frs' ) THEN + ilen1(:)=idx_bdy(jbdy)%nblen(:) + ELSE + ilen1(:)=idx_bdy(jbdy)%nblenrim(:) + ENDIF + + IF( ASSOCIATED(dta_bdy(jbdy)%ssh) ) dta_bdy_s(jbdy)%ssh(1:ilen1(1)) = dta_bdy(jbdy)%ssh(1:ilen1(1)) + IF( ASSOCIATED(dta_bdy(jbdy)%u2d) ) dta_bdy_s(jbdy)%u2d(1:ilen1(2)) = dta_bdy(jbdy)%u2d(1:ilen1(2)) + IF( ASSOCIATED(dta_bdy(jbdy)%v2d) ) dta_bdy_s(jbdy)%v2d(1:ilen1(3)) = dta_bdy(jbdy)%v2d(1:ilen1(3)) + 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, kt_offset=kt_offset ) + 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 ! + ! + 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 + ! -------------- + REWIND(numnam_cfg) + 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 do a rewind + REWIND(numnam_ref) + 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 + ! WARNING: we don't do a rewind here, each bdy reads its own nambdy_dta block one after another + READ ( numnam_cfg, 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_clopn( bf(jp_bdya_i,jbdy), nyear, nmonth, nday ) ! not a problem when we call it again after + 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 + bf(jp_bdya_i,jbdy)%clrootname = 'NOT USED' ! reset to default value as this subdomain may not need to read this bdy + ENDIF + ENDIF + +#if defined key_si3 + IF( .NOT.ln_pnd ) THEN + rn_ice_apnd = 0. ; rn_ice_hpnd = 0. ; rn_ice_hlid = 0. + CALL ctl_warn( 'rn_ice_apnd & rn_ice_hpnd = 0 & rn_ice_hlid = 0 when no ponds' ) + ENDIF + IF( .NOT.ln_pnd_lids ) THEN + rn_ice_hlid = 0. + 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/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn.F90 new file mode 100644 index 0000000..b96a678 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn.F90 @@ -0,0 +1,122 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn( kt, dyn3d_only ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn *** + !! + !! ** Purpose : - Wrapper routine for bdy_dyn2d and bdy_dyn3d. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + LOGICAL, INTENT(in), OPTIONAL :: 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) :: pua2d, pva2d ! 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: + pua2d(:,:) = 0._wp + pva2d(:,:) = 0._wp + DO jk = 1, jpkm1 + pua2d(:,:) = pua2d(:,:) + e3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) + pva2d(:,:) = pva2d(:,:) + e3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) + END DO + pua2d(:,:) = pua2d(:,:) * r1_hu_a(:,:) + pva2d(:,:) = pva2d(:,:) * r1_hv_a(:,:) + + DO jk = 1 , jpkm1 + ua(:,:,jk) = ( ua(:,:,jk) - pua2d(:,:) ) * umask(:,:,jk) + va(:,:,jk) = ( va(:,:,jk) - pva2d(:,:) ) * vmask(:,:,jk) + END DO + + + IF( ll_orlanski ) THEN ! "Before" velocities (Orlanski condition only) + DO jk = 1 , jpkm1 + ub(:,:,jk) = ( ub(:,:,jk) - ub_b(:,:) ) * umask(:,:,jk) + vb(:,:,jk) = ( vb(:,:,jk) - vb_b(:,:) ) * vmask(:,:,jk) + END DO + ENDIF + + !------------------------------------------------------- + ! Apply boundary conditions to barotropic and baroclinic + ! parts separately + !------------------------------------------------------- + + IF( ll_dyn2d ) CALL bdy_dyn2d( kt, pua2d, pva2d, ub_b, vb_b, r1_hu_a(:,:), r1_hv_a(:,:), ssha ) + + IF( ll_dyn3d ) CALL bdy_dyn3d( kt ) + + !------------------------------------------------------- + ! Recombine velocities + !------------------------------------------------------- + ! + DO jk = 1 , jpkm1 + ua(:,:,jk) = ( ua(:,:,jk) + pua2d(:,:) ) * umask(:,:,jk) + va(:,:,jk) = ( va(:,:,jk) + pva2d(:,:) ) * vmask(:,:,jk) + END DO + ! + IF ( ll_orlanski ) THEN + DO jk = 1 , jpkm1 + ub(:,:,jk) = ( ub(:,:,jk) + ub_b(:,:) ) * umask(:,:,jk) + vb(:,:,jk) = ( vb(:,:,jk) + vb_b(:,:) ) * vmask(:,:,jk) + END DO + END IF + ! + END SUBROUTINE bdy_dyn + + !!====================================================================== +END MODULE bdydyn diff --git a/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn2d.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn2d.F90 new file mode 100644 index 0000000..ca54faa --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn2d.F90 @@ -0,0 +1,334 @@ +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 lbclnk ! ocean lateral boundary conditions (or mpp link) + USE wet_dry ! Use wet dry to get reference ssh level + USE in_out_manager ! + USE lib_mpp, ONLY: ctl_stop + + 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$ + !! 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(wp), DIMENSION(jpi,jpj), INTENT(in ) :: pssh + !! + INTEGER :: ib_bdy, ir ! BDY set index, rim index + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(4) :: 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') + llsend2(1:2) = llsend2(1:2) .OR. lsend_bdyint(ib_bdy,2,1:2,ir) ! west/east, U points + llsend2(1) = llsend2(1) .OR. lsend_bdyext(ib_bdy,2,1,ir) ! neighbour might search point towards its east bdy + llrecv2(1:2) = llrecv2(1:2) .OR. lrecv_bdyint(ib_bdy,2,1:2,ir) ! west/east, U points + llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(ib_bdy,2,2,ir) ! might search point towards bdy on the east + llsend3(3:4) = llsend3(3:4) .OR. lsend_bdyint(ib_bdy,3,3:4,ir) ! north/south, V points + llsend3(3) = llsend3(3) .OR. lsend_bdyext(ib_bdy,3,3,ir) ! neighbour might search point towards its north bdy + llrecv3(3:4) = llrecv3(3:4) .OR. lrecv_bdyint(ib_bdy,3,3:4,ir) ! north/south, V points + llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(ib_bdy,3,4,ir) ! might search point towards bdy on the north + CASE('orlanski', 'orlanski_npo') + llsend2(:) = llsend2(:) .OR. lsend_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(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., 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., 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) :: pssh, phur, phvr + 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(wp), 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(4) :: 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., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + END DO + ! + END SUBROUTINE bdy_ssh + + !!====================================================================== +END MODULE bdydyn2d + diff --git a/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn3d.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn3d.F90 new file mode 100644 index 0000000..5126b74 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdydyn3d.F90 @@ -0,0 +1,398 @@ +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 lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! + USE lib_mpp, ONLY: ctl_stop + 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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_dyn3d( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d *** + !! + !! ** Purpose : - Apply open boundary conditions for baroclinic velocities + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + ! + INTEGER :: ib_bdy, ir ! BDY set index, rim index + LOGICAL :: llrim0 ! indicate if rim 0 is treated + LOGICAL, DIMENSION(4) :: 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( 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( 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( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy ) + CASE('orlanski' ) ; CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.false. ) + CASE('orlanski_npo'); CALL bdy_dyn3d_orlanski( idx_bdy(ib_bdy), dta_bdy(ib_bdy), ib_bdy, llrim0, ll_npo=.true. ) + CASE('zerograd') ; CALL bdy_dyn3d_zgrad( idx_bdy(ib_bdy), dta_bdy(ib_bdy), kt, ib_bdy, llrim0 ) + CASE('neumann') ; CALL bdy_dyn3d_nmn( 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_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points + llrecv2(:) = llrecv2(:) .OR. lrecv_bdy(ib_bdy,2,:,ir) ! possibly every direction, U points + llsend3(:) = llsend3(:) .OR. lsend_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points + llrecv3(:) = llrecv3(:) .OR. lrecv_bdy(ib_bdy,3,:,ir) ! possibly every direction, V points + CASE('zerograd') + llsend2(3:4) = llsend2(3:4) .OR. lsend_bdyint(ib_bdy,2,3:4,ir) ! north/south, U points + llrecv2(3:4) = llrecv2(3:4) .OR. lrecv_bdyint(ib_bdy,2,3:4,ir) ! north/south, U points + llsend3(1:2) = llsend3(1:2) .OR. lsend_bdyint(ib_bdy,3,1:2,ir) ! west/east, V points + llrecv3(1:2) = llrecv3(1:2) .OR. lrecv_bdyint(ib_bdy,3,1:2,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', ua, 'U', -1., 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', va, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + END DO ! ir + ! + END SUBROUTINE bdy_dyn3d + + + SUBROUTINE bdy_dyn3d_spe( idx, dta, kt , ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_spe *** + !! + !! ** Purpose : - Apply a specified value for baroclinic velocities + !! at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step index + 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 + !!---------------------------------------------------------------------- + ! + 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) + ua(ii,ij,jk) = 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) + va(ii,ij,jk) = dta%v3d(jb,jk) * vmask(ii,ij,jk) + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_spe + + + SUBROUTINE bdy_dyn3d_zgrad( idx, dta, kt, ib_bdy, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_zgrad *** + !! + !! ** Purpose : - Enforce a zero gradient of normal velocity + !! + !!---------------------------------------------------------------------- + INTEGER :: kt + 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 + !! + 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 + ua(ii,ij,jk) = ua(ii,ij+flagv,jk) * 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 + va(ii,ij,jk) = va(ii+flagu,ij,jk) * vmask(ii+flagu,ij,jk) + END DO + ! + END IF + END DO + ! + END SUBROUTINE bdy_dyn3d_zgrad + + + SUBROUTINE bdy_dyn3d_zro( idx, dta, kt, ib_bdy ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_zro *** + !! + !! ** Purpose : - baroclinic velocities = 0. at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step index + 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 + ua(ii,ij,ik) = 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 + va(ii,ij,ik) = 0._wp + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_zro + + + SUBROUTINE bdy_dyn3d_frs( 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 + 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) + ua(ii,ij,jk) = ( ua(ii,ij,jk) + zwgt * ( dta%u3d(jb,jk) - ua(ii,ij,jk) ) ) * 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) + va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta%v3d(jb,jk) - va(ii,ij,jk) ) ) * vmask(ii,ij,jk) + END DO + END DO + ! + END SUBROUTINE bdy_dyn3d_frs + + + SUBROUTINE bdy_dyn3d_orlanski( 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) + !!---------------------------------------------------------------------- + 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 ub and ua arrays contain the baroclinic velocities. + ! + igrd = 2 ! Orlanski bc on u-velocity; + ! + CALL bdy_orlanski_3d( idx, igrd, ub, ua, dta%u3d, ll_npo, llrim0 ) + + igrd = 3 ! Orlanski bc on v-velocity + ! + CALL bdy_orlanski_3d( idx, igrd, vb, va, dta%v3d, ll_npo, llrim0 ) + ! + END SUBROUTINE bdy_dyn3d_orlanski + + + SUBROUTINE bdy_dyn3d_dmp( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_dmp *** + !! + !! ** Purpose : Apply damping for baroclinic velocities at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step index + ! + INTEGER :: jb, jk ! dummy loop indices + INTEGER :: ib_bdy ! loop index + INTEGER :: ii, ij, igrd ! local integers + REAL(wp) :: zwgt ! boundary weight + !!---------------------------------------------------------------------- + ! + 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 + ua(ii,ij,jk) = ( ua(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%u3d(jb,jk) - & + ub(ii,ij,jk) + ub_b(ii,ij)) ) * 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 + va(ii,ij,jk) = ( va(ii,ij,jk) + zwgt * ( dta_bdy(ib_bdy)%v3d(jb,jk) - & + vb(ii,ij,jk) + vb_b(ii,ij)) ) * 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( idx, ib_bdy, llrim0 ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_dyn3d_nmn *** + !! + !! - Apply Neumann condition to baroclinic velocities. + !! - Wrapper routine for bdy_nmn + !! + !! + !!---------------------------------------------------------------------- + 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 ub and ua arrays contain the baroclinic velocities. + ! + igrd = 2 ! Neumann bc on u-velocity; + ! + CALL bdy_nmn( idx, igrd, ua, llrim0 ) ! ua is masked + + igrd = 3 ! Neumann bc on v-velocity + ! + CALL bdy_nmn( idx, igrd, va, llrim0 ) ! va is masked + ! + END SUBROUTINE bdy_dyn3d_nmn + + !!====================================================================== +END MODULE bdydyn3d diff --git a/NEMO_4.0.4_surge/src/OCE/BDY/bdyice.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdyice.F90 new file mode 100644 index 0000000..c4e278e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdyice.F90 @@ -0,0 +1,475 @@ +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 + !!---------------------------------------------------------------------- +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea ice model + !!---------------------------------------------------------------------- + !! bdy_ice : Application of open boundaries to ice + !! bdy_ice_frs : Application of Flow Relaxation Scheme + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE ice ! sea-ice: variables + USE icevar ! sea-ice: operations + USE icecor ! sea-ice: corrections + USE icectl ! sea-ice: control prints + USE phycst ! physical constant + USE eosbn2 ! equation of state + USE par_oce ! ocean parameters + USE dom_oce ! ocean space and time domain variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE bdy_oce ! ocean open boundary conditions + ! + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! write to numout file + USE lib_mpp ! distributed memory computing + USE lib_fortran ! to use key_nosignedzero + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC bdy_ice ! routine called in sbcmod + PUBLIC bdy_ice_dyn ! routine called in icedyn_rhg_evp + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_ice( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_ice *** + !! + !! ** Purpose : Apply open boundary conditions for sea ice + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + ! + INTEGER :: jbdy, ir ! BDY set 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(4) :: llsend1, llrecv1 ! indicate how communications are to be carried out + !!---------------------------------------------------------------------- + ! controls + IF( ln_timing ) CALL timing_start('bdy_ice_thd') ! timing + ! + CALL ice_var_glo2eqv + ! + llsend1(:) = .false. ; llrecv1(:) = .false. + DO ir = 1, 0, -1 ! treat rim 1 before rim 0 + IF( ir == 0 ) THEN ; llrim0 = .TRUE. + ELSE ; llrim0 = .FALSE. + END IF + DO jbdy = 1, nb_bdy + ! + SELECT CASE( cn_ice(jbdy) ) + CASE('none') ; CYCLE + CASE('frs' ) ; CALL bdy_ice_frs( idx_bdy(jbdy), dta_bdy(jbdy), kt, jbdy, llrim0 ) + CASE DEFAULT + CALL ctl_stop( 'bdy_ice : unrecognised option for open boundaries for ice fields' ) + END SELECT + ! + END DO + ! + ! Update bdy points + 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. ; END IF + DO jbdy = 1, nb_bdy + IF( cn_ice(jbdy) == 'frs' ) THEN + llsend1(:) = llsend1(:) .OR. lsend_bdyint(jbdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdyint(jbdy,1,:,ir) ! possibly every direction, T points + END IF + END DO ! jbdy + IF( ANY(llsend1) .OR. ANY(llrecv1) ) THEN ! if need to send/recv in at least one direction + ! exchange 3d arrays + CALL lbc_lnk_multi( 'bdyice', a_i , 'T', 1., h_i , 'T', 1., h_s , 'T', 1., oa_i, 'T', 1. & + & , s_i , 'T', 1., t_su, 'T', 1., v_i , 'T', 1., v_s , 'T', 1., sv_i, 'T', 1. & + & , a_ip, 'T', 1., v_ip, 'T', 1., v_il, 'T', 1. & + & , kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + ! exchange 4d arrays : third dimension = 1 and then third dimension = jpk + CALL lbc_lnk_multi( 'bdyice', t_s , 'T', 1., e_s , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + CALL lbc_lnk_multi( 'bdyice', t_i , 'T', 1., e_i , 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + END DO ! ir + ! + CALL ice_cor( kt , 0 ) ! -- In case categories are out of bounds, do a remapping + ! ! i.e. inputs have not the same ice thickness distribution (set by rn_himean) + ! ! than the regional simulation + CALL ice_var_agg(1) + ! + ! controls + IF( ln_icectl ) CALL ice_prt ( kt, iiceprt, jiceprt, 1, ' - ice thermo bdy - ' ) ! prints + IF( ln_timing ) CALL timing_stop ('bdy_ice_thd') ! timing + ! + END SUBROUTINE bdy_ice + + + SUBROUTINE bdy_ice_frs( idx, dta, kt, jbdy, llrim0 ) + !!------------------------------------------------------------------------------ + !! *** SUBROUTINE bdy_ice_frs *** + !! + !! ** Purpose : Apply the Flow Relaxation Scheme for sea-ice fields + !! + !! Reference : 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) :: kt ! main time-step counter + INTEGER, INTENT(in) :: jbdy ! BDY set index + LOGICAL, INTENT(in) :: llrim0 ! indicate if rim 0 is treated + ! + INTEGER :: jpbound ! 0 = incoming ice + ! ! 1 = outgoing ice + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + INTEGER :: i_bdy, jgrd ! dummy loop indices + INTEGER :: ji, jj, jk, jl, ib, jb + REAL(wp) :: zwgt, zwgt1 ! local scalar + REAL(wp) :: ztmelts, zdh + REAL(wp), POINTER :: flagu, flagv ! short cuts + !!------------------------------------------------------------------------------ + ! + jgrd = 1 ! Everything is at T-points here + IF( llrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(jgrd) + ELSE ; ibeg = idx%nblenrim0(jgrd)+1 ; iend = idx%nblenrim(jgrd) + END IF + ! + DO jl = 1, jpl + DO i_bdy = ibeg, iend + ji = idx%nbi(i_bdy,jgrd) + jj = idx%nbj(i_bdy,jgrd) + zwgt = idx%nbw(i_bdy,jgrd) + zwgt1 = 1.e0 - idx%nbw(i_bdy,jgrd) + a_i (ji,jj, jl) = ( a_i (ji,jj, jl) * zwgt1 + dta%a_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice concentration + h_i (ji,jj, jl) = ( h_i (ji,jj, jl) * zwgt1 + dta%h_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice depth + h_s (ji,jj, jl) = ( h_s (ji,jj, jl) * zwgt1 + dta%h_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow depth + t_i (ji,jj,:,jl) = ( t_i (ji,jj,:,jl) * zwgt1 + dta%t_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice temperature + t_s (ji,jj,:,jl) = ( t_s (ji,jj,:,jl) * zwgt1 + dta%t_s(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Snow temperature + t_su(ji,jj, jl) = ( t_su(ji,jj, jl) * zwgt1 + dta%tsu(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Surf temperature + s_i (ji,jj, jl) = ( s_i (ji,jj, jl) * zwgt1 + dta%s_i(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice salinity + a_ip(ji,jj, jl) = ( a_ip(ji,jj, jl) * zwgt1 + dta%aip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond concentration + h_ip(ji,jj, jl) = ( h_ip(ji,jj, jl) * zwgt1 + dta%hip(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond depth + h_il(ji,jj, jl) = ( h_il(ji,jj, jl) * zwgt1 + dta%hil(i_bdy,jl) * zwgt ) * tmask(ji,jj,1) ! Ice pond lid depth + ! + sz_i(ji,jj,:,jl) = s_i(ji,jj,jl) + ! + ! make sure ponds = 0 if no ponds scheme + IF( .NOT.ln_pnd ) THEN + a_ip(ji,jj,jl) = 0._wp + h_ip(ji,jj,jl) = 0._wp + h_il(ji,jj,jl) = 0._wp + ENDIF + + IF( .NOT.ln_pnd_lids ) THEN + h_il(ji,jj,jl) = 0._wp + ENDIF + ! + ! ----------------- + ! Pathological case + ! ----------------- + ! In case a) snow load would be in excess or b) ice is coming into a warmer environment that would lead to + ! very large transformation from snow to ice (see icethd_dh.F90) + + ! Then, a) transfer the snow excess into the ice (different from icethd_dh) + zdh = MAX( 0._wp, ( rhos * h_s(ji,jj,jl) + ( rhoi - rau0 ) * h_i(ji,jj,jl) ) * r1_rau0 ) + ! Or, b) transfer all the snow into ice (if incoming ice is likely to melt as it comes into a warmer environment) + !zdh = MAX( 0._wp, h_s(ji,jj,jl) * rhos / rhoi ) + + ! recompute h_i, h_s + h_i(ji,jj,jl) = MIN( hi_max(jl), h_i(ji,jj,jl) + zdh ) + h_s(ji,jj,jl) = MAX( 0._wp, h_s(ji,jj,jl) - zdh * rhoi / rhos ) + ! + ENDDO + ENDDO + + DO jl = 1, jpl + DO i_bdy = ibeg, iend + ji = idx%nbi(i_bdy,jgrd) + jj = idx%nbj(i_bdy,jgrd) + flagu => idx%flagu(i_bdy,jgrd) + flagv => idx%flagv(i_bdy,jgrd) + ! condition on ice thickness depends on the ice velocity + ! if velocity is outward (strictly), then ice thickness, volume... must be equal to adjacent values + jpbound = 0 ; ib = ji ; jb = jj + ! + IF( flagu == 1. ) THEN + IF( ji+1 > jpi ) CYCLE + IF( u_ice(ji ,jj ) < 0. ) jpbound = 1 ; ib = ji+1 + END IF + IF( flagu == -1. ) THEN + IF( ji-1 < 1 ) CYCLE + IF( u_ice(ji-1,jj ) < 0. ) jpbound = 1 ; ib = ji-1 + END IF + IF( flagv == 1. ) THEN + IF( jj+1 > jpj ) CYCLE + IF( v_ice(ji ,jj ) < 0. ) jpbound = 1 ; jb = jj+1 + END IF + IF( flagv == -1. ) THEN + IF( jj-1 < 1 ) CYCLE + IF( v_ice(ji ,jj-1) < 0. ) jpbound = 1 ; jb = jj-1 + END IF + ! + IF( nn_ice_dta(jbdy) == 0 ) jpbound = 0 ; ib = ji ; jb = jj ! case ice boundaries = initial conditions + ! ! do not make state variables dependent on velocity + ! + IF( a_i(ib,jb,jl) > 0._wp ) THEN ! there is ice at the boundary + ! + a_i (ji,jj, jl) = a_i (ib,jb, jl) + h_i (ji,jj, jl) = h_i (ib,jb, jl) + h_s (ji,jj, jl) = h_s (ib,jb, jl) + t_i (ji,jj,:,jl) = t_i (ib,jb,:,jl) + t_s (ji,jj,:,jl) = t_s (ib,jb,:,jl) + t_su(ji,jj, jl) = t_su(ib,jb, jl) + s_i (ji,jj, jl) = s_i (ib,jb, jl) + a_ip(ji,jj, jl) = a_ip(ib,jb, jl) + h_ip(ji,jj, jl) = h_ip(ib,jb, jl) + h_il(ji,jj, jl) = h_il(ib,jb, jl) + ! + sz_i(ji,jj,:,jl) = sz_i(ib,jb,:,jl) + ! + ! ice age + IF ( jpbound == 0 ) THEN ! velocity is inward + oa_i(ji,jj,jl) = rice_age(jbdy) * a_i(ji,jj,jl) + ELSEIF( jpbound == 1 ) THEN ! velocity is outward + oa_i(ji,jj,jl) = oa_i(ib,jb,jl) + ENDIF + ! + IF( nn_icesal == 1 ) THEN ! if constant salinity + s_i (ji,jj ,jl) = rn_icesal + sz_i(ji,jj,:,jl) = rn_icesal + ENDIF + ! + ! global fields + v_i (ji,jj,jl) = h_i(ji,jj,jl) * a_i(ji,jj,jl) ! volume ice + v_s (ji,jj,jl) = h_s(ji,jj,jl) * a_i(ji,jj,jl) ! volume snw + sv_i(ji,jj,jl) = MIN( s_i(ji,jj,jl) , sss_m(ji,jj) ) * v_i(ji,jj,jl) ! salt content + DO jk = 1, nlay_s + t_s(ji,jj,jk,jl) = MIN( t_s(ji,jj,jk,jl), -0.15_wp + rt0 ) ! Force t_s to be lower than -0.15deg (arbitrary) => likely conservation issue + ! ! otherwise instant melting can occur + e_s(ji,jj,jk,jl) = rhos * ( rcpi * ( rt0 - t_s(ji,jj,jk,jl) ) + rLfus ) ! enthalpy in J/m3 + e_s(ji,jj,jk,jl) = e_s(ji,jj,jk,jl) * v_s(ji,jj,jl) * r1_nlay_s ! enthalpy in J/m2 + END DO + t_su(ji,jj,jl) = MIN( t_su(ji,jj,jl), -0.15_wp + rt0 ) ! Force t_su to be lower than -0.15deg (arbitrary) + DO jk = 1, nlay_i + ztmelts = - rTmlt * sz_i(ji,jj,jk,jl) ! Melting temperature in C + t_i(ji,jj,jk,jl) = MIN( t_i(ji,jj,jk,jl), (ztmelts-0.15_wp) + rt0 ) ! Force t_i to be lower than melting point (-0.15) => likely conservation issue + ! ! otherwise instant melting can occur + e_i(ji,jj,jk,jl) = rhoi * ( rcpi * ( ztmelts - ( t_i(ji,jj,jk,jl) - rt0 ) ) & ! enthalpy in J/m3 + & + rLfus * ( 1._wp - ztmelts / ( t_i(ji,jj,jk,jl) - rt0 ) ) & + & - rcp * ztmelts ) + e_i(ji,jj,jk,jl) = e_i(ji,jj,jk,jl) * v_i(ji,jj,jl) * r1_nlay_i ! enthalpy in J/m2 + END DO + ! + ! melt ponds + v_ip(ji,jj,jl) = h_ip(ji,jj,jl) * a_ip(ji,jj,jl) + v_il(ji,jj,jl) = h_il(ji,jj,jl) * a_ip(ji,jj,jl) + ! + ELSE ! no ice at the boundary + ! + a_i (ji,jj, jl) = 0._wp + h_i (ji,jj, jl) = 0._wp + h_s (ji,jj, jl) = 0._wp + oa_i(ji,jj, jl) = 0._wp + t_su(ji,jj, jl) = rt0 + t_s (ji,jj,:,jl) = rt0 + t_i (ji,jj,:,jl) = rt0 + + a_ip(ji,jj,jl) = 0._wp + h_ip(ji,jj,jl) = 0._wp + h_il(ji,jj,jl) = 0._wp + + IF( nn_icesal == 1 ) THEN ! if constant salinity + s_i (ji,jj ,jl) = rn_icesal + sz_i(ji,jj,:,jl) = rn_icesal + ELSE ! if variable salinity + s_i (ji,jj,jl) = rn_simin + sz_i(ji,jj,:,jl) = rn_simin + ENDIF + ! + ! global fields + v_i (ji,jj, jl) = 0._wp + v_s (ji,jj, jl) = 0._wp + sv_i(ji,jj, jl) = 0._wp + e_s (ji,jj,:,jl) = 0._wp + e_i (ji,jj,:,jl) = 0._wp + v_ip(ji,jj, jl) = 0._wp + v_il(ji,jj, jl) = 0._wp + + ENDIF + + END DO + ! + END DO ! jl + ! + END SUBROUTINE bdy_ice_frs + + + SUBROUTINE bdy_ice_dyn( cd_type ) + !!------------------------------------------------------------------------------ + !! *** SUBROUTINE bdy_ice_dyn *** + !! + !! ** Purpose : Apply dynamics boundary conditions for sea-ice. + !! + !! ** Method : if this adjacent grid point is not ice free, then u_ice and v_ice take its value + !! if is ice free, then u_ice and v_ice are unchanged by BDY + !! they keep values calculated in rheology + !! + !!------------------------------------------------------------------------------ + CHARACTER(len=1), INTENT(in) :: cd_type ! nature of velocity grid-points + ! + INTEGER :: i_bdy, jgrd ! dummy loop indices + INTEGER :: ji, jj ! local scalar + INTEGER :: jbdy, ir ! BDY set index, rim index + INTEGER :: ibeg, iend ! length of rim to be treated (rim 0 or rim 1) + REAL(wp) :: zmsk1, zmsk2, zflag + LOGICAL, DIMENSION(4) :: llsend2, llrecv2, llsend3, llrecv3 ! indicate how communications are to be carried out + !!------------------------------------------------------------------------------ + IF( ln_timing ) CALL timing_start('bdy_ice_dyn') + ! + llsend2(:) = .false. ; llrecv2(:) = .false. + llsend3(:) = .false. ; llrecv3(:) = .false. + DO ir = 1, 0, -1 + DO jbdy = 1, nb_bdy + ! + SELECT CASE( cn_ice(jbdy) ) + ! + CASE('none') + CYCLE + ! + CASE('frs') + ! + IF( nn_ice_dta(jbdy) == 0 ) CYCLE ! case ice boundaries = initial conditions + ! ! do not change ice velocity (it is only computed by rheology) + SELECT CASE ( cd_type ) + ! + CASE ( 'U' ) + jgrd = 2 ! u velocity + IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) + ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) + END IF + DO i_bdy = ibeg, iend + ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) + jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) + zflag = idx_bdy(jbdy)%flagu(i_bdy,jgrd) + ! i-1 i i | ! i i i+1 | ! i i i+1 | + ! > ice > | ! o > ice | ! o > o | + ! => set at u_ice(i-1) ! => set to O ! => unchanged + IF( zflag == -1. .AND. ji > 1 .AND. ji < jpi ) THEN + IF ( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji-1,jj) + ELSEIF( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = 0._wp + END IF + END IF + ! | i i+1 i+1 ! | i i i+1 ! | i i i+1 + ! | > ice > ! | ice > o ! | o > o + ! => set at u_ice(i+1) ! => set to O ! => unchanged + IF( zflag == 1. .AND. ji+1 < jpi+1 ) THEN + IF ( vt_i(ji+1,jj) > 0. ) THEN ; u_ice(ji,jj) = u_ice(ji+1,jj) + ELSEIF( vt_i(ji ,jj) > 0. ) THEN ; u_ice(ji,jj) = 0._wp + END IF + END IF + ! + IF( zflag == 0. ) u_ice(ji,jj) = 0._wp ! u_ice = 0 if north/south bdy + ! + END DO + ! + CASE ( 'V' ) + jgrd = 3 ! v velocity + IF( ir == 0 ) THEN ; ibeg = 1 ; iend = idx_bdy(jbdy)%nblenrim0(jgrd) + ELSE ; ibeg = idx_bdy(jbdy)%nblenrim0(jgrd)+1 ; iend = idx_bdy(jbdy)%nblenrim(jgrd) + END IF + DO i_bdy = ibeg, iend + ji = idx_bdy(jbdy)%nbi(i_bdy,jgrd) + jj = idx_bdy(jbdy)%nbj(i_bdy,jgrd) + zflag = idx_bdy(jbdy)%flagv(i_bdy,jgrd) + ! ! ice (jj+1) ! o (jj+1) + ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) + ! ice (jj ) ! o (jj ) ! o (jj ) + ! ^ (jj-1) ! ! + ! => set to u_ice(jj-1) ! => set to 0 ! => unchanged + IF( zflag == -1. .AND. jj > 1 .AND. jj < jpj ) THEN + IF ( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj-1) + ELSEIF( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = 0._wp + END IF + END IF + ! ^ (jj+1) ! ! + ! ice (jj+1) ! o (jj+1) ! o (jj+1) + ! ^ (jj ) ! ^ (jj ) ! ^ (jj ) + ! ________________ ! ____ice___(jj )_ ! _____o____(jj ) + ! => set to u_ice(jj+1) ! => set to 0 ! => unchanged + IF( zflag == 1. .AND. jj < jpj ) THEN + IF ( vt_i(ji,jj+1) > 0. ) THEN ; v_ice(ji,jj) = v_ice(ji,jj+1) + ELSEIF( vt_i(ji,jj ) > 0. ) THEN ; v_ice(ji,jj) = 0._wp + END IF + END IF + ! + IF( zflag == 0. ) v_ice(ji,jj) = 0._wp ! v_ice = 0 if west/east bdy + ! + END DO + ! + END SELECT + ! + CASE DEFAULT + CALL ctl_stop( 'bdy_ice_dyn : unrecognised option for open boundaries for ice fields' ) + END SELECT + ! + END DO ! jbdy + ! + SELECT CASE ( cd_type ) + CASE ( 'U' ) + 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. ; END IF + DO jbdy = 1, nb_bdy + IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN + llsend2(:) = llsend2(:) .OR. lsend_bdyint(jbdy,2,:,ir) ! possibly every direction, U points + llsend2(1) = llsend2(1) .OR. lsend_bdyext(jbdy,2,1,ir) ! neighbour might search point towards its west bdy + llrecv2(:) = llrecv2(:) .OR. lrecv_bdyint(jbdy,2,:,ir) ! possibly every direction, U points + llrecv2(2) = llrecv2(2) .OR. lrecv_bdyext(jbdy,2,2,ir) ! might search point towards east bdy + END IF + END DO + IF( ANY(llsend2) .OR. ANY(llrecv2) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdyice', u_ice, 'U', -1., kfillmode=jpfillnothing ,lsend=llsend2, lrecv=llrecv2 ) + END IF + CASE ( 'V' ) + 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 ; llsend3(:) = .false. ; llrecv3(:) = .false. ; END IF + DO jbdy = 1, nb_bdy + IF( cn_ice(jbdy) == 'frs' .AND. nn_ice_dta(jbdy) /= 0 ) THEN + llsend3(:) = llsend3(:) .OR. lsend_bdyint(jbdy,3,:,ir) ! possibly every direction, V points + llsend3(3) = llsend3(3) .OR. lsend_bdyext(jbdy,3,3,ir) ! neighbour might search point towards its south bdy + llrecv3(:) = llrecv3(:) .OR. lrecv_bdyint(jbdy,3,:,ir) ! possibly every direction, V points + llrecv3(4) = llrecv3(4) .OR. lrecv_bdyext(jbdy,3,4,ir) ! might search point towards north bdy + END IF + END DO + IF( ANY(llsend3) .OR. ANY(llrecv3) ) THEN ! if need to send/recv in at least one direction + CALL lbc_lnk( 'bdyice', v_ice, 'V', -1., kfillmode=jpfillnothing ,lsend=llsend3, lrecv=llrecv3 ) + END IF + END SELECT + END DO ! ir + ! + IF( ln_timing ) CALL timing_stop('bdy_ice_dyn') + ! + END SUBROUTINE bdy_ice_dyn + +#else + !!--------------------------------------------------------------------------------- + !! 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 +#endif + + !!================================================================================= +END MODULE bdyice diff --git a/NEMO_4.0.4_surge/src/OCE/BDY/bdyini.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdyini.F90 new file mode 100644 index 0000000..77210d1 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdyini.F90 @@ -0,0 +1,1795 @@ +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 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 sbctide ! Tidal forcing or not + 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 ! + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + ! ------------------------ + REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries + 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) + REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries + 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 :: ib_bdy, ii, ij, igrd, ib, ir, iseg ! dummy loop indices + INTEGER :: icount, icountr, icountr0, ibr_max ! local integers + INTEGER :: ilen1 ! - - + 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 + !!---------------------------------------------------------------------- + ! + cgrid = (/'t','u','v'/) + + ! ----------------------------------------- + ! Check and write out namelist parameters + ! ----------------------------------------- + IF( jperio /= 0 ) CALL ctl_stop( 'bdy_segs: Cyclic or symmetric,', & + & ' and general open boundary condition are not compatible' ) + + 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,*) + +#if defined key_si3 + IF(lwp) THEN + WRITE(numout,*) 'Boundary conditions for sea ice: ' + SELECT CASE( cn_ice(ib_bdy) ) + CASE('none') ; WRITE(numout,*) ' no open boundary condition' + CASE('frs') ; WRITE(numout,*) ' Flow Relaxation Scheme' + CASE DEFAULT ; CALL ctl_stop( 'unrecognised value for cn_ice' ) + END SELECT + ENDIF + + dta_bdy(ib_bdy)%lneed_ice = cn_ice(ib_bdy) /= 'none' + + IF( lwp .AND. dta_bdy(ib_bdy)%lneed_ice ) THEN + SELECT CASE( nn_ice_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_ice_dta must be 0 or 1' ) + END SELECT + ENDIF +#else + dta_bdy(ib_bdy)%lneed_ice = .FALSE. +#endif + ! + 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 + ! ------------------------------------------------- + + REWIND( numnam_cfg ) + 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) ) + 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) ) + 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(ib2, igrd, ib_bdy2) =-ib_bdy2 + nbjdta(ib2, igrd, ib_bdy2) =-ib_bdy2 + ELSEIF (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_bdy(nb_bdy,jpbgrd,4,0:1), lrecv_bdy(nb_bdy,jpbgrd,4,0:1) ) + lsend_bdy(:,:,:,:) = .false. + lrecv_bdy(:,:,:,:) = .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 + ! W neighbour and on the inner left side + IF( ii == 2 .and. (nbondi == 0 .or. nbondi == 1) ) lsend_bdy(ib_bdy,igrd,1,ir) = .true. + ! E neighbour and on the inner right side + IF( ii == jpi-1 .and. (nbondi == 0 .or. nbondi == -1) ) lsend_bdy(ib_bdy,igrd,2,ir) = .true. + ! S neighbour and on the inner down side + IF( ij == 2 .and. (nbondj == 0 .or. nbondj == 1) ) lsend_bdy(ib_bdy,igrd,3,ir) = .true. + ! N neighbour and on the inner up side + IF( ij == jpj-1 .and. (nbondj == 0 .or. nbondj == -1) ) lsend_bdy(ib_bdy,igrd,4,ir) = .true. + ! + ! check if point has to be received from a neighbour + ! W neighbour and on the outter left side + IF( ii == 1 .and. (nbondi == 0 .or. nbondi == 1) ) lrecv_bdy(ib_bdy,igrd,1,ir) = .true. + ! E neighbour and on the outter right side + IF( ii == jpi .and. (nbondi == 0 .or. nbondi == -1) ) lrecv_bdy(ib_bdy,igrd,2,ir) = .true. + ! S neighbour and on the outter down side + IF( ij == 1 .and. (nbondj == 0 .or. nbondj == 1) ) lrecv_bdy(ib_bdy,igrd,3,ir) = .true. + ! N neighbour and on the outter up side + IF( ij == jpj .and. (nbondj == 0 .or. nbondj == -1) ) lrecv_bdy(ib_bdy,igrd,4,ir) = .true. + ! + END DO + END DO ! igrd + + ! 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) = 1.- TANH( FLOAT( ir - 1 ) * 0.5 & + & *(10./FLOAT(nn_rimwidth(ib_bdy))) ) ! JGraham:modified for rim=15 + ! 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 ij = 1, jpjm1 + DO ii = 1, jpim1 + zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & + & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) + END DO + END DO + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) + + ! Read global 2D mask at T-points: bdytmask + ! ----------------------------------------- + ! bdytmask = 1 on the computational domain AND on open boundaries + ! = 0 elsewhere + + bdytmask(:,:) = ssmask(:,:) + + ! Derive mask on U and V grid from mask on T grid + DO ij = 1, jpjm1 + DO ii = 1, jpim1 + bdyumask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii+1,ij ) + bdyvmask(ii,ij) = bdytmask(ii,ij) * bdytmask(ii ,ij+1) + END DO + END DO + CALL lbc_lnk_multi( 'bdyini', bdyumask, 'U', 1., bdyvmask, 'V', 1. ) ! 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 ij = 1, jpjm1 + DO ii = 1, jpim1 + zfmask(ii,ij) = ztmask(ii,ij ) * ztmask(ii+1,ij ) & + & * ztmask(ii,ij+1) * ztmask(ii+1,ij+1) + END DO + END DO + CALL lbc_lnk( 'bdyini', zfmask, 'F', 1. ) + + ! 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,4,0:1), lrecv_bdyint(nb_bdy,jpbgrd,4,0:1) ) + lsend_bdyint(:,:,:,:) = .false. + lrecv_bdyint(:,:,:,:) = .false. + ALLOCATE( lsend_bdyext(nb_bdy,jpbgrd,4,0:1), lrecv_bdyext(nb_bdy,jpbgrd,4,0:1) ) + lsend_bdyext(:,:,:,:) = .false. + lrecv_bdyext(:,:,:,:) = .false. + ! + DO igrd = 1, jpbgrd + DO ib_bdy = 1, nb_bdy + 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 + ! + ! search neighbour in the west/east direction + ! Rim is on the halo and computed ocean is towards exterior of mpi domain + ! <-- (o exterior) --> + ! (1) o|x OR (2) x|o + ! |___ ___| + IF( iibi == 0 .OR. ii1 == 0 .OR. ii2 == 0 .OR. ii3 == 0 ) lrecv_bdyint(ib_bdy,igrd,1,ir) = .true. + IF( iibi == jpi+1 .OR. ii1 == jpi+1 .OR. ii2 == jpi+1 .OR. ii3 == jpi+1 ) lrecv_bdyint(ib_bdy,igrd,2,ir) = .true. + IF( iibe == 0 ) lrecv_bdyext(ib_bdy,igrd,1,ir) = .true. + IF( iibe == jpi+1 ) lrecv_bdyext(ib_bdy,igrd,2,ir) = .true. + ! Check if neighbour has its rim parallel to its mpi subdomain border and located next to its halo + ! :¨¨¨¨¨|¨¨--> | | <--¨¨|¨¨¨¨¨: + ! : | x:o | neighbour limited by ... would need o | o:x | : + ! :.....|_._:_____| (1) W neighbour E neighbour (2) |_____:_._|.....: + IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. & + & ( iibi == 3 .OR. ii1 == 3 .OR. ii2 == 3 .OR. ii3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,1,ir)=.true. + IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. & + & ( iibi == jpi-2 .OR. ii1 == jpi-2 .OR. ii2 == jpi-2 .OR. ii3 == jpi-2) ) lsend_bdyint(ib_bdy,igrd,2,ir)=.true. + IF( ii == 2 .AND. ( nbondi == 1 .OR. nbondi == 0 ) .AND. iibe == 3 ) lsend_bdyext(ib_bdy,igrd,1,ir)=.true. + IF( ii == jpi-1 .AND. ( nbondi == -1 .OR. nbondi == 0 ) .AND. iibe == jpi-2 ) lsend_bdyext(ib_bdy,igrd,2,ir)=.true. + ! + ! search neighbour in the north/south direction + ! Rim is on the halo and computed ocean is towards exterior of mpi domain + !(3) | | ^ ___o___ + ! | |___x___| OR | | x | + ! v o (4) | | + IF( ijbi == 0 .OR. ij1 == 0 .OR. ij2 == 0 .OR. ij3 == 0 ) lrecv_bdyint(ib_bdy,igrd,3,ir) = .true. + IF( ijbi == jpj+1 .OR. ij1 == jpj+1 .OR. ij2 == jpj+1 .OR. ij3 == jpj+1 ) lrecv_bdyint(ib_bdy,igrd,4,ir) = .true. + IF( ijbe == 0 ) lrecv_bdyext(ib_bdy,igrd,3,ir) = .true. + IF( ijbe == jpj+1 ) lrecv_bdyext(ib_bdy,igrd,4,ir) = .true. + ! Check if neighbour has its rim parallel to its mpi subdomain _________ border and next to its halo + ! ^ | o | : : + ! | |¨¨¨¨x¨¨¨¨| neighbour limited by ... would need o | |....x....| + ! :_________: (3) S neighbour N neighbour (4) v | o | + IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. & + & ( ijbi == 3 .OR. ij1 == 3 .OR. ij2 == 3 .OR. ij3 == 3 ) ) lsend_bdyint(ib_bdy,igrd,3,ir)=.true. + IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. & + & ( ijbi == jpj-2 .OR. ij1 == jpj-2 .OR. ij2 == jpj-2 .OR. ij3 == jpj-2) ) lsend_bdyint(ib_bdy,igrd,4,ir)=.true. + IF( ij == 2 .AND. ( nbondj == 1 .OR. nbondj == 0 ) .AND. ijbe == 3 ) lsend_bdyext(ib_bdy,igrd,3,ir)=.true. + IF( ij == jpj-1 .AND. ( nbondj == -1 .OR. nbondj == 0 ) .AND. ijbe == jpj-2 ) lsend_bdyext(ib_bdy,igrd,4,ir)=.true. + END DO + END DO + END DO + + 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( mig(ii) > 2 .AND. mig(ii) < jpiglo-2 .AND. mjg(ij) > 2 .AND. mjg(ij) < jpjglo-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 ) :: pfmask ! temporary fmask excluding coastal boundary condition (shlat) + REAL(wp), TARGET, DIMENSION(jpi,jpj), INTENT (in ) :: pumask, pvmask ! temporary t/u/v mask array + 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 + + ! 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 + DO igrd = 1, jpbgrd + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => pumask ; i_offset = 0 + CASE( 2 ) ; zmask => bdytmask ; i_offset = 1 + CASE( 3 ) ; zmask => pfmask ; i_offset = 0 + END SELECT + icount = 0 + ztmp(:,:) = -999._wp + 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 + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + 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 + IF( i_offset == 1 .and. zefl + zwfl == 2. ) 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. ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) + 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 + 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 + DO igrd = 1, jpbgrd + 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 + 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 + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + 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 + IF( j_offset == 1 .and. znfl + zsfl == 2. ) 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. ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) + 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 + END DO + ! + END DO ! ib_bdy + + DO ib_bdy = 1, nb_bdy + DO igrd = 1, jpbgrd + SELECT CASE( igrd ) + CASE( 1 ) ; zmask => bdytmask + CASE( 2 ) ; zmask => bdyumask + CASE( 3 ) ; zmask => bdyvmask + END SELECT + ztmp(:,:) = -999._wp + 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 + DO ib = ibeg, iend + ii = idx_bdy(ib_bdy)%nbi(ib,igrd) + ij = idx_bdy(ib_bdy)%nbj(ib,igrd) + IF( ii == 1 .OR. ii == jpi .OR. ij == 1 .OR. ij == jpj ) CYCLE + llnon = zmask(ii ,ij+1) == 1. + llson = zmask(ii ,ij-1) == 1. + llean = zmask(ii+1,ij ) == 1. + llwen = zmask(ii-1,ij ) == 1. + 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. ) THEN ; ztmp(ii,ij) = 1. + ELSEIF( zmask(ii-1,ij+1) == 1. ) THEN ; ztmp(ii,ij) = 2. + ELSEIF( zmask(ii+1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 3. + ELSEIF( zmask(ii-1,ij-1) == 1. ) THEN ; ztmp(ii,ij) = 4. + ELSE ; ztmp(ii,ij) = -1. + 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. + IF( llwen ) ztmp(ii,ij) = 6. + IF( llnon ) ztmp(ii,ij) = 7. + IF( llson ) ztmp(ii,ij) = 8. + 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. + IF( llnon .AND. llwen ) ztmp(ii,ij) = 10. + IF( llson .AND. llean ) ztmp(ii,ij) = 11. + IF( llson .AND. llwen ) ztmp(ii,ij) = 12. + 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. + IF( llnon .AND. llwen .AND. llson ) ztmp(ii,ij) = 14. + IF( llwen .AND. llson .AND. llean ) ztmp(ii,ij) = 15. + IF( llwen .AND. llnon .AND. llean ) ztmp(ii,ij) = 16. + 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. ) + CASE( 2 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'U', 1. ) + CASE( 3 ) ; CALL lbc_lnk( 'bdyini', ztmp, 'V', 1. ) + 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 + END DO + + 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_coords_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 + CHARACTER(LEN=1) :: ctypebdy ! - - + NAMELIST/nambdy_index/ ctypebdy, nbdyind, nbdybeg, nbdyend + !!---------------------------------------------------------------------- + + ! No REWIND here because may need to read more than one nambdy_index namelist. + ! Read only namelist_cfg to avoid unseccessfull overwrite + ! keep full control of the configuration namelist + READ ( numnam_cfg, 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 = jpjglo - 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = jpiglo - 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 = jpiglo - 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 = jpiglo - 2 ! set boundary to whole side of model domain. + nbdybeg = 2 + nbdyend = jpjglo - 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 = jpjglo - 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.jpjglo-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.jpiglo) 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.jpjglo-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.jpiglo) 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.jpiglo-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.jpjglo) 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.jpiglo-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.jpjglo) 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 (((ji + nimpp - 1) == jpiwob(ib)).AND. & + & ((jj + njmpp - 1) == jpjwdt(ib))) ztestmask(1)=tmask(ji,jj,1) + IF (((ji + nimpp - 1) == jpiwob(ib)).AND. & + & ((jj + njmpp - 1) == 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 (((ji + nimpp - 1) == jpieob(ib)+1).AND. & + & ((jj + njmpp - 1) == jpjedt(ib))) ztestmask(1)=tmask(ji,jj,1) + IF (((ji + nimpp - 1) == jpieob(ib)+1).AND. & + & ((jj + njmpp - 1) == 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 (((jj + njmpp - 1) == jpjsob(ib)).AND. & + & ((ji + nimpp - 1) == jpisdt(ib))) ztestmask(1)=tmask(ji,jj,1) + IF (((jj + njmpp - 1) == jpjsob(ib)).AND. & + & ((ji + nimpp - 1) == 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 (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & + & ((ji + nimpp - 1) == jpindt(ib))) ztestmask(1)=tmask(ji,jj,1) + IF (((jj + njmpp - 1) == jpjnob(ib)+1).AND. & + & ((ji + nimpp - 1) == 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 + nbjdta(icount, igrd, ib_bdy) = ij + 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 + nbjdta(icount, igrd, ib_bdy) = ij + 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 + nbjdta(icount, igrd, ib_bdy) = ij + 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 + nbjdta(icount, igrd, ib_bdy) = ij + 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 + nbjdta(icount, igrd, ib_bdy) = ij + 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 + nbjdta(icount, igrd, ib_bdy) = ij + 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 + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + 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 + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 2 - ir + 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 + nbjdta(icount, igrd, ib_bdy) = jpjnob(iseg) + 1 - ir + 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 + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + 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 + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + 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 + nbjdta(icount, igrd, ib_bdy) = jpjsob(iseg) + ir - 1 + 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/NEMO_4.0.4_surge/src/OCE/BDY/bdylib.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdylib.F90 new file mode 100644 index 0000000..098675e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdylib.F90 @@ -0,0 +1,527 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_frs( idx, pta, 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(:,:), INTENT(in) :: dta ! OBC external data + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! 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) + pta(ii,ij,ik) = ( pta(ii,ij,ik) + zwgt * (dta(ib,ik) - pta(ii,ij,ik) ) ) * tmask(ii,ij,ik) + END DO + END DO + ! + END SUBROUTINE bdy_frs + + + SUBROUTINE bdy_spe( idx, pta, 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(:,:), INTENT(in) :: dta ! OBC external data + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! 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 + pta(ii,ij,ik) = dta(ib,ik) * tmask(ii,ij,ik) + END DO + END DO + ! + END SUBROUTINE bdy_spe + + + SUBROUTINE bdy_orl( idx, ptb, pta, 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(:,:), INTENT(in) :: dta ! OBC external data + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptb ! before tracer field + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! tracer trend + LOGICAL , OPTIONAL, 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, ptb(:,:,:), pta(:,:,:), 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(:) , INTENT(in ) :: phi_ext ! external forcing data + LOGICAL, OPTIONAL, 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(wp) :: 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(wp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(wp), 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( PRESENT(lrim0) ) THEN + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + END IF + ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both + END IF + ! + 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 rdt 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., 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., zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*rdt*( (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., 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 ) + end if + 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(wp), DIMENSION(:,:,:), INTENT(in ) :: phib ! model before 3D field + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated) + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: phi_ext ! external forcing data + LOGICAL, OPTIONAL, 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(wp) :: 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(wp), POINTER, DIMENSION(:,:) :: pe_xdif ! scale factors for x-derivatives + REAL(wp), 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( PRESENT(lrim0) ) THEN + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + END IF + ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both + END IF + ! + 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., 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., zrx ) + zout = 0.5*( zout + abs(zout) ) + zwgt = 2.*rdt*( (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., 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 ) + end if + 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(wp), DIMENSION(:,:,:), INTENT(inout) :: phia ! model after 3D field (to be updated), must be masked + TYPE(OBC_INDEX), INTENT(in ) :: idx ! OBC indices + LOGICAL, OPTIONAL, 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( PRESENT(lrim0) ) THEN + IF( lrim0 ) THEN ; ibeg = 1 ; iend = idx%nblenrim0(igrd) ! rim 0 + ELSE ; ibeg = idx%nblenrim0(igrd)+1 ; iend = idx%nblenrim(igrd) ! rim 1 + END IF + ELSE ; ibeg = 1 ; iend = idx%nblenrim(igrd) ! both + END IF + ! + 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/NEMO_4.0.4_surge/src/OCE/BDY/bdytides.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdytides.F90 new file mode 100644 index 0000000..1199b98 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdytides.F90 @@ -0,0 +1,566 @@ +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 tideini ! + 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 bdytide_update ! routine called in bdy_dta + 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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + LOGICAL :: ln_bdytide_conj ! If true, assume complex conjugate tidal data + !! + INTEGER :: ib_bdy, itide, ib ! dummy loop indices + INTEGER :: ii, ij ! dummy loop indices + INTEGER :: inum, igrd + INTEGER, DIMENSION(3) :: ilen0 ! length of boundary data (from OBC arrays) + INTEGER :: ios ! Local integer output status for namelist read + 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, ln_bdytide_conj + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'bdytide_init : initialization of tidal harmonic forcing at open boundaries' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + REWIND(numnam_cfg) + + 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(:) = '' + + REWIND( numnam_ref ) + READ ( numnam_ref, nambdy_tide, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy_tide in reference namelist' ) + ! Don't REWIND here - may need to read more than one of these namelists. + READ ( numnam_cfg, 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,*) ' assume complex conjugate : ', ln_bdytide_conj + 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,*) ' ', Wave(ntide(itide))%cname_tide + END DO + ENDIF + IF(lwp) WRITE(numout,*) ' ' + + ! If FRS scheme is used, we assume that tidal is needed over the whole relaxation area + IF( cn_dyn2d(ib_bdy) == 'frs' ) THEN ; ilen0(:) = idx_bdy(ib_bdy)%nblen (:) + ELSE ; ilen0(:) = idx_bdy(ib_bdy)%nblenrim(:) + ENDIF + + ! 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 + ALLOCATE( td%ssh0( ilen0(1), nb_harmo, 2 ), td%ssh( ilen0(1), nb_harmo, 2 ), dta_bdy_s(ib_bdy)%ssh( ilen0(1) ) ) + dta_bdy_s(ib_bdy)%ssh(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + ALLOCATE( td%u0 ( ilen0(2), nb_harmo, 2 ), td%u ( ilen0(2), nb_harmo, 2 ), dta_bdy_s(ib_bdy)%u2d( ilen0(2) ) ) + dta_bdy_s(ib_bdy)%u2d(:) = 0._wp ! needed? + ENDIF + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + ALLOCATE( td%v0 ( ilen0(3), nb_harmo, 2 ), td%v ( ilen0(3), nb_harmo, 2 ), dta_bdy_s(ib_bdy)%v2d( ilen0(3) ) ) + 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_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_z1', ztr(:,:) ) + CALL iom_get( inum, jpdom_autoglo, TRIM(Wave(ntide(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_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_u1', ztr(:,:) ) + CALL iom_get ( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_u2', zti(:,:) ) + 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 + END IF + 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_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_v1', ztr(:,:) ) + CALL iom_get ( inum, jpdom_autoglo, TRIM(Wave(ntide(itide))%cname_tide)//'_v2', zti(:,:) ) + 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 + END IF + 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 + clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_T.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'z1', dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,1) = dta_read(1:ilen0(1),1,1) + CALL fld_map( inum, 'z2', dta_read(1:ilen0(1),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,1) ) + td%ssh0(:,itide,2) = dta_read(1:ilen0(1),1,1) + CALL iom_close( inum ) + ENDIF + ! ! U fields + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_U.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'u1', dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,1) = dta_read(1:ilen0(2),1,1) + CALL fld_map( inum, 'u2', dta_read(1:ilen0(2),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,2) ) + td%u0(:,itide,2) = dta_read(1:ilen0(2),1,1) + CALL iom_close( inum ) + ENDIF + ! ! V fields + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + clfile = TRIM(filtide)//TRIM(Wave(ntide(itide))%cname_tide)//'_grid_V.nc' + CALL iom_open( clfile, inum ) + CALL fld_map( inum, 'v1', dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,1) = dta_read(1:ilen0(3),1,1) + CALL fld_map( inum, 'v2', dta_read(1:ilen0(3),1:1,1:1) , 1, idx_bdy(ib_bdy)%nbmap(:,3) ) + td%v0(:,itide,2) = dta_read(1:ilen0(3),1,1) + CALL iom_close( inum ) + ENDIF + ! + END DO ! end loop on tidal components + ! + DEALLOCATE( dta_read ) + ! + ENDIF ! ln_bdytide_2ddta=.true. + ! + IF( ln_bdytide_conj ) THEN ! assume complex conjugate in data files + IF( ASSOCIATED(dta%ssh) ) td%ssh0(:,:,2) = - td%ssh0(:,:,2) + IF( ASSOCIATED(dta%u2d) ) td%u0 (:,:,2) = - td%u0 (:,:,2) + IF( ASSOCIATED(dta%v2d) ) td%v0 (:,:,2) = - td%v0 (:,:,2) + ENDIF + ! + ENDIF ! nn_dyn2d_dta(ib_bdy) >= 2 + ! + END DO ! loop on ib_bdy + ! + END SUBROUTINE bdytide_init + + + SUBROUTINE bdytide_update( kt, idx, dta, td, kit, kt_offset ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdytide_update *** + !! + !! ** Purpose : - Add tidal forcing to ssh, u2d and v2d OBC data arrays. + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! Main timestep counter + TYPE(OBC_INDEX) , INTENT(in ) :: idx ! OBC indices + TYPE(OBC_DATA) , INTENT(inout) :: dta ! OBC external data + TYPE(TIDES_DATA) , INTENT(inout) :: td ! tidal harmonics data + INTEGER, OPTIONAL, INTENT(in ) :: kit ! Barotropic timestep counter (for timesplitting option) + INTEGER, OPTIONAL, INTENT(in ) :: kt_offset ! time offset in units of timesteps. NB. if kit + ! ! is present then units = subcycle timesteps. + ! ! kt_offset = 0 => get data at "now" time level + ! ! kt_offset = -1 => get data at "before" time level + ! ! kt_offset = +1 => get data at "after" time level + ! ! etc. + ! + INTEGER :: itide, ib ! dummy loop indices + INTEGER :: time_add ! time offset in units of timesteps + INTEGER :: isz ! bdy data size + REAL(wp) :: z_arg, z_sarg, zflag, zramp ! local scalars + REAL(wp), DIMENSION(jpmax_harmo) :: z_sist, z_cost + !!---------------------------------------------------------------------- + ! + zflag=1 + IF ( PRESENT(kit) ) THEN + IF ( kit /= 1 ) zflag=0 + ENDIF + ! + IF ( (nsec_day == NINT(0.5_wp * rdt) .OR. kt==nit000) .AND. zflag==1 ) THEN + ! + kt_tide = kt - (nsec_day - 0.5_wp * rdt)/rdt + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'bdytide_update : (re)Initialization of the tidal bdy forcing at kt=',kt + WRITE(numout,*) '~~~~~~~~~~~~~~ ' + ENDIF + ! + CALL tide_init_elevation ( idx, td ) + CALL tide_init_velocities( idx, td ) + ! + ENDIF + + time_add = 0 + IF( PRESENT(kt_offset) ) THEN + time_add = kt_offset + ENDIF + + IF( PRESENT(kit) ) THEN + z_arg = ((kt-kt_tide) * rdt + (kit+0.5_wp*(time_add-1)) * rdt / REAL(nn_baro,wp) ) + ELSE + z_arg = ((kt-kt_tide)+time_add) * rdt + ENDIF + + ! Linear ramp on tidal component at open boundaries + zramp = 1._wp + IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg + (kt_tide-nit000)*rdt)/(rdttideramp*rday),0._wp),1._wp) + + DO itide = 1, nb_harmo + z_sarg = z_arg * omega_tide(itide) + z_cost(itide) = COS( z_sarg ) + z_sist(itide) = SIN( z_sarg ) + END DO + + DO itide = 1, nb_harmo + ! SSH on tracer grid + IF( ASSOCIATED(dta%ssh) ) THEN ! we use bdy ssh on this mpi subdomain + DO ib = 1, SIZE(dta%ssh) + dta%ssh(ib) = dta%ssh(ib) + zramp*(td%ssh(ib,itide,1)*z_cost(itide) + td%ssh(ib,itide,2)*z_sist(itide)) + END DO + ENDIF + ! U grid + IF( ASSOCIATED(dta%u2d) ) THEN ! we use bdy u2d on this mpi subdomain + DO ib = 1, SIZE(dta%u2d) + dta%u2d(ib) = dta%u2d(ib) + zramp*(td%u (ib,itide,1)*z_cost(itide) + td%u (ib,itide,2)*z_sist(itide)) + END DO + ENDIF + ! V grid + IF( ASSOCIATED(dta%v2d) ) THEN ! we use bdy v2d on this mpi subdomain + DO ib = 1, SIZE(dta%v2d) + dta%v2d(ib) = dta%v2d(ib) + zramp*(td%v (ib,itide,1)*z_cost(itide) + td%v (ib,itide,2)*z_sist(itide)) + END DO + ENDIF + END DO + ! + END SUBROUTINE bdytide_update + + + SUBROUTINE bdy_dta_tides( kt, kit, kt_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) + INTEGER, OPTIONAL, INTENT(in) :: kt_offset ! time offset in units of timesteps. NB. if kit + ! ! is present then units = subcycle timesteps. + ! ! kt_offset = 0 => get data at "now" time level + ! ! kt_offset = -1 => get data at "before" time level + ! ! kt_offset = +1 => get data at "after" time level + ! ! etc. + ! + LOGICAL :: lk_first_btstp ! =.TRUE. if time splitting and first barotropic step + INTEGER :: itide, ib_bdy, ib ! loop indices + INTEGER :: time_add ! time offset in units of timesteps + REAL(wp) :: z_arg, z_sarg, zramp, zoff, z_cost, z_sist + !!---------------------------------------------------------------------- + ! + lk_first_btstp=.TRUE. + IF ( PRESENT(kit).AND.( kit /= 1 ) ) THEN ; lk_first_btstp=.FALSE. ; ENDIF + + time_add = 0 + IF( PRESENT(kt_offset) ) THEN + time_add = kt_offset + ENDIF + + ! Absolute time from model initialization: + IF( PRESENT(kit) ) THEN + z_arg = ( kt + (kit+time_add-1) / REAL(nn_baro,wp) ) * rdt + ELSE + z_arg = ( kt + time_add ) * rdt + ENDIF + + ! Linear ramp on tidal component at open boundaries + zramp = 1. + IF (ln_tide_ramp) zramp = MIN(MAX( (z_arg - nit000*rdt)/(rdttideramp*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 * rdt) .OR. kt==nit000 ) .AND. lk_first_btstp ) THEN + ! + kt_tide = kt - (nsec_day - 0.5_wp * rdt)/rdt + ! + 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 = -kt_tide * rdt ! 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) * omega_tide(itide) + 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 + END IF + 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)*ftide(itide) + phi_tide(ib)=phi_tide(ib)+v0tide(itide)+utide(itide) + 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)*ftide(itide) + phi_tide(ib)=phi_tide(ib)+v0tide(itide)+utide(itide) + 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)*ftide(itide) + phi_tide(ib)=phi_tide(ib)+v0tide(itide)+utide(itide) + 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/NEMO_4.0.4_surge/src/OCE/BDY/bdytra.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdytra.F90 new file mode 100644 index 0000000..316be8a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdytra.F90 @@ -0,0 +1,181 @@ +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 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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE bdy_tra( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_tra *** + !! + !! ** Purpose : - Apply open boundary conditions for temperature and salinity + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! Main time step counter + ! + 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(4) :: 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. + END IF + 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( TRIM(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), tsa(:,:,:,jn), zdta(jn)%tra ) + CASE('specified' ) ! treat the whole rim at once + IF( ir == 0 ) CALL bdy_spe ( idx_bdy(ib_bdy), tsa(:,:,:,jn), zdta(jn)%tra ) + CASE('neumann' ) ; CALL bdy_nmn ( idx_bdy(ib_bdy), igrd , tsa(:,:,:,jn), llrim0 ) ! tsa masked + CASE('orlanski' ) ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & + & zdta(jn)%tra, llrim0, ll_npo=.false. ) + CASE('orlanski_npo') ; CALL bdy_orl ( idx_bdy(ib_bdy), tsb(:,:,:,jn), tsa(:,:,:,jn), & + & zdta(jn)%tra, llrim0, ll_npo=.true. ) + CASE('runoff' ) ; CALL bdy_rnf ( idx_bdy(ib_bdy), tsa(:,:,:,jn), 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. ; END IF + DO ib_bdy=1, nb_bdy + SELECT CASE( TRIM(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_bdy(ib_bdy,1,:,ir) ! possibly every direction, T points + llrecv1(:) = llrecv1(:) .OR. lrecv_bdy(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', tsa, 'T', 1., kfillmode=jpfillnothing ,lsend=llsend1, lrecv=llrecv1 ) + END IF + ! + END DO ! ir + ! + END SUBROUTINE bdy_tra + + + SUBROUTINE bdy_rnf( idx, pta, 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(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pta ! 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 + INTEGER :: ik, ip, jp ! 2D addresses + !!---------------------------------------------------------------------- + ! + igrd = 1 ! Everything is at T-points here + IF( jpa == jp_tem ) THEN + CALL bdy_nmn( idx, igrd, pta, 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) + pta(ii,ij,1:jpkm1) = 0.1 * tmask(ii,ij,1:jpkm1) + END DO + END IF + ! + END SUBROUTINE bdy_rnf + + + SUBROUTINE bdy_tra_dmp( kt ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE bdy_tra_dmp *** + !! + !! ** Purpose : Apply damping for tracers at open boundaries. + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! + ! + 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( 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) - tsb(ii,ij,ik,jp_tem) ) * tmask(ii,ij,ik) + zsa = zwgt * ( dta_bdy(ib_bdy)%sal(ib,ik) - tsb(ii,ij,ik,jp_sal) ) * tmask(ii,ij,ik) + tsa(ii,ij,ik,jp_tem) = tsa(ii,ij,ik,jp_tem) + zta + tsa(ii,ij,ik,jp_sal) = tsa(ii,ij,ik,jp_sal) + 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/NEMO_4.0.4_surge/src/OCE/BDY/bdyvol.F90 b/NEMO_4.0.4_surge/src/OCE/BDY/bdyvol.F90 new file mode 100644 index 0000000..f1a8f35 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/BDY/bdyvol.F90 @@ -0,0 +1,229 @@ +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 dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbcisf ! ice shelf + ! + 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$ + !! 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(:,:) ) * bdytmask(:,:) * e1e2t(:,:) ) / rau0 + + ! 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/NEMO_4.0.4_surge/src/OCE/C1D/c1d.F90 b/NEMO_4.0.4_surge/src/OCE/C1D/c1d.F90 new file mode 100644 index 0000000..bf70d46 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/C1D/c1d.F90 @@ -0,0 +1,87 @@ +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 + !!---------------------------------------------------------------------- +#if defined key_c1d + !!---------------------------------------------------------------------- + !! 'key_c1d' 1D column configuration + !!---------------------------------------------------------------------- + !! 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 + + LOGICAL , PUBLIC, PARAMETER :: lk_c1d = .TRUE. ! 1D config. flag + + REAL(wp), PUBLIC :: rn_lat1d !: Column latitude + REAL(wp), PUBLIC :: rn_lon1d !: Column longitude + LOGICAL , PUBLIC :: ln_c1d_locpt !: Localization (or not) of 1D column in a grid + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 , ln_c1d_locpt + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namc1d in reference namelist : Tracer advection scheme + READ ( numnam_ref, namc1d, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme + 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 + WRITE(numout,*) ' column localization in a grid ln_c1d_locpt = ', ln_c1d_locpt + ENDIF + ! + END SUBROUTINE c1d_init + +#else + !!---------------------------------------------------------------------- + !! Dummy module : No use of 1D configuration + !!---------------------------------------------------------------------- + USE par_kind ! kind parameters + LOGICAL, PUBLIC, PARAMETER :: lk_c1d = .FALSE. !: 1D config. flag de-activated + REAL(wp) :: rn_lat1d, rn_lon1d + LOGICAL , PUBLIC :: ln_c1d_locpt = .FALSE. +CONTAINS + SUBROUTINE c1d_init ! Dummy routine + END SUBROUTINE c1d_init +#endif + + !!====================================================================== +END MODULE c1d diff --git a/NEMO_4.0.4_surge/src/OCE/C1D/dtauvd.F90 b/NEMO_4.0.4_surge/src/OCE/C1D/dtauvd.F90 new file mode 100644 index 0000000..e635782 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/C1D/dtauvd.F90 @@ -0,0 +1,225 @@ +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 ! Flag to initialise with U & V current data + LOGICAL , PUBLIC :: ln_uvd_dyndmp ! 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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + + REWIND( numnam_ref ) ! Namelist namc1d_uvd in reference namelist : + READ ( numnam_ref, namc1d_uvd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_uvd in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namc1d_uvd in configuration namelist : Parameters of the run + 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, puvd ) + !!---------------------------------------------------------------------- + !! *** 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 + REAL(wp), DIMENSION(jpi,jpj,jpk,2), INTENT( out) :: puvd ! 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 ==! + ! + puvd(:,:,:,1) = sf_uvd(1)%fnow(:,:,:) ! NO mask + puvd(:,:,:,2) = 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 = 1, jpj ! vertical interpolation of U & V current: + DO ji = 1, jpi ! determines the interpolated U & V current profiles at each (i,j) point + DO jk = 1, jpk + zl = gdept_n(ji,jj,jk) + IF ( zl < gdept_1d(1 ) ) THEN ! extrapolate above the first level of data + zup(jk) = puvd(ji,jj,1 ,1) + zvp(jk) = puvd(ji,jj,1 ,2) + ELSEIF( zl > gdept_1d(jpk) ) THEN ! extrapolate below the last level of data + zup(jk) = puvd(ji,jj,jpkm1,1) + zvp(jk) = puvd(ji,jj,jpkm1,2) + 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)) + zup(jk) = puvd(ji,jj,jkk,1) + ( puvd(ji,jj,jkk+1,1 ) - puvd(ji,jj,jkk,1) ) * zi + zvp(jk) = puvd(ji,jj,jkk,2) + ( puvd(ji,jj,jkk+1,2 ) - puvd(ji,jj,jkk,2) ) * zi + ENDIF + END DO + ENDIF + END DO + DO jk = 1, jpkm1 ! apply mask + puvd(ji,jj,jk,1) = zup(jk) * umask(ji,jj,jk) + puvd(ji,jj,jk,2) = zvp(jk) * vmask(ji,jj,jk) + END DO + puvd(ji,jj,jpk,1) = 0._wp + puvd(ji,jj,jpk,2) = 0._wp + END DO + END DO + ! + DEALLOCATE( zup, zvp ) + ! + ELSE !== z- or zps- coordinate ==! + ! + puvd(:,:,:,1) = puvd(:,:,:,1) * umask(:,:,:) ! apply mask + puvd(:,:,:,2) = puvd(:,:,:,2) * vmask(:,:,:) + ! + IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbkt(ji,jj) + IF( ik > 1 ) THEN + zl = ( gdept_1d(ik) - gdept_0(ji,jj,ik) ) / ( gdept_1d(ik) - gdept_1d(ik-1) ) + puvd(ji,jj,ik,1) = (1.-zl) * puvd(ji,jj,ik,1) + zl * puvd(ji,jj,ik-1,1) + puvd(ji,jj,ik,2) = (1.-zl) * puvd(ji,jj,ik,2) + zl * puvd(ji,jj,ik-1,2) + 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/NEMO_4.0.4_surge/src/OCE/C1D/dyncor_c1d.F90 b/NEMO_4.0.4_surge/src/OCE/C1D/dyncor_c1d.F90 new file mode 100644 index 0000000..5483467 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/C1D/dyncor_c1d.F90 @@ -0,0 +1,118 @@ +MODULE dyncor_c1d + !!====================================================================== + !! *** MODULE dyncor_c1d *** + !! Ocean Dynamics : Coriolis term in 1D configuration + !!===================================================================== + !! History : 2.0 ! 2004-09 (C. Ethe) Original code + !! 3.0 ! 2008-04 (G. Madec) style only + !!---------------------------------------------------------------------- +#if defined key_c1d + !!---------------------------------------------------------------------- + !! 'key_c1d' 1D Configuration + !!---------------------------------------------------------------------- + !! cor_c1d : Coriolis factor at T-point (1D configuration) + !! dyn_cor_c1d : vorticity trend due to Coriolis at T-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 prtctl ! Print control + + USE sbcwave ! Surface Waves (add Stokes-Coriolis force) + USE sbc_oce , ONLY : ln_stcor ! use Stoke-Coriolis force + + IMPLICIT NONE + PRIVATE + + PUBLIC cor_c1d ! called by nemogcm.F90 + PUBLIC dyn_cor_c1d ! called by step1d.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE cor_c1d + !!---------------------------------------------------------------------- + !! *** ROUTINE cor_c1d *** + !! + !! ** Purpose : set the Coriolis factor at T-point + !!---------------------------------------------------------------------- + REAL(wp) :: zphi0, zbeta, zf0 ! local scalars + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'cor_c1d : Coriolis factor at T-point' + IF(lwp) WRITE(numout,*) '~~~~~~~' + + ! + END SUBROUTINE cor_c1d + + + SUBROUTINE dyn_cor_c1d( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_cor_c1d *** + !! + !! ** Purpose : Compute the now Coriolis trend and add it to + !! the general trend of the momentum equation in 1D case. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_cor_c1d : total vorticity trend in 1D' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~' + ENDIF + ! + IF( ln_stcor ) THEN + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) + ff_t(ji,jj) * (vn(ji,jj,jk) + vsd(ji,jj,jk)) + va(ji,jj,jk) = va(ji,jj,jk) - ff_t(ji,jj) * (un(ji,jj,jk) + usd(ji,jj,jk)) + END DO + END DO + END DO + ELSE + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) + ff_t(ji,jj) * vn(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ff_t(ji,jj) * un(ji,jj,jk) + END DO + END DO + END DO + END IF + + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' cor - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2=' Va: ' , mask2=vmask ) + ! + END SUBROUTINE dyn_cor_c1d + +#else + !!---------------------------------------------------------------------- + !! Default key NO 1D Configuration + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE cor_c1d ! Empty routine + IMPLICIT NONE + END SUBROUTINE cor_c1d + SUBROUTINE dyn_cor_c1d ( kt ) ! Empty routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'dyn_cor_c1d: You should not have seen this print! error?', kt + END SUBROUTINE dyn_cor_c1d +#endif + + !!===================================================================== +END MODULE dyncor_c1d diff --git a/NEMO_4.0.4_surge/src/OCE/C1D/dyndmp.F90 b/NEMO_4.0.4_surge/src/OCE/C1D/dyndmp.F90 new file mode 100644 index 0000000..f8755ca --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/C1D/dyndmp.F90 @@ -0,0 +1,230 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namc1d_dyndmp in reference namelist : + READ ( numnam_ref, namc1d_dyndmp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namc1d_dyndmp in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namc1d_dyndmp in configuration namelist : Parameters of the run + 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_autoglo, 'resto', resto) + CALL iom_close( imask ) + ENDIF + ! + END SUBROUTINE dyn_dmp_init + + + SUBROUTINE dyn_dmp( kt ) + !!---------------------------------------------------------------------- + !! *** 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: + !! ua = ua + resto_uv * (u_dta - ub) + !! va = va + resto_uv * (v_dta - vb) + !! 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 : - (ua,va) momentum trends updated with the damping trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zua, zva ! local scalars + REAL(wp), 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, zuv_dta ) !!! NOTE: This subroutine must be altered for use outside + !!! the C1D context (use of U,V grid variables) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - ub(ji,jj,jk) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - vb(ji,jj,jk) ) + ua(ji,jj,jk) = ua(ji,jj,jk) + zua + va(ji,jj,jk) = va(ji,jj,jk) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( avt(ji,jj,jk) <= avt_c ) THEN + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - ub(ji,jj,jk) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - vb(ji,jj,jk) ) + ELSE + zua = 0._wp + zva = 0._wp + ENDIF + ua(ji,jj,jk) = ua(ji,jj,jk) + zua + va(ji,jj,jk) = va(ji,jj,jk) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( gdept_n(ji,jj,jk) >= hmlp (ji,jj) ) THEN + zua = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,1) - ub(ji,jj,jk) ) + zva = resto_uv(ji,jj,jk) * ( zuv_dta(ji,jj,jk,2) - vb(ji,jj,jk) ) + ELSE + zua = 0._wp + zva = 0._wp + ENDIF + ua(ji,jj,jk) = ua(ji,jj,jk) + zua + va(ji,jj,jk) = va(ji,jj,jk) + 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( ln_ctl ) CALL prt_ctl( tab3d_1=ua(:,:,:), clinfo1=' dmp - Ua: ', mask1=umask, & + & tab3d_2=va(:,:,:), clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + ! + IF( ln_timing ) CALL timing_stop( 'dyn_dmp') + ! + END SUBROUTINE dyn_dmp + + !!====================================================================== +END MODULE dyndmp diff --git a/NEMO_4.0.4_surge/src/OCE/C1D/step_c1d.F90 b/NEMO_4.0.4_surge/src/OCE/C1D/step_c1d.F90 new file mode 100644 index 0000000..14f901a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/C1D/step_c1d.F90 @@ -0,0 +1,153 @@ +MODULE step_c1d + !!====================================================================== + !! *** MODULE step_c1d *** + !! Time-stepping : manager of the ocean, tracer and ice time stepping - c1d case + !!====================================================================== + !! History : 2.0 ! 2004-04 (C. Ethe) adapted from step.F90 for C1D + !! 3.0 ! 2008-04 (G. Madec) redo the adaptation to include SBC + !!---------------------------------------------------------------------- +#if defined key_c1d + !!---------------------------------------------------------------------- + !! 'key_c1d' 1D Configuration + !!---------------------------------------------------------------------- + !! stp_c1d : NEMO system time-stepping in c1d case + !!---------------------------------------------------------------------- + USE step_oce ! time stepping definition modules +#if defined key_top + USE trcstp ! passive tracer time-stepping (trc_stp routine) +#endif + USE dyncor_c1d ! Coriolis term (c1d case) (dyn_cor_1d ) + USE dynnxt ! time-stepping (dyn_nxt routine) + USE dyndmp ! U & V momentum damping (dyn_dmp routine) + USE restart ! restart + + IMPLICIT NONE + PRIVATE + + PUBLIC stp_c1d ! called by opa.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE stp_c1d( kstp ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_c1d *** + !! + !! ** Purpose : - Time stepping of SBC including sea ice (dynamic and thermodynamic eqs.) + !! - Time stepping of OPA (momentum and active tracer eqs.) + !! - Time stepping of TOP (passive tracer eqs.) + !! + !! ** Method : -1- Update forcings and data + !! -2- Update vertical 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, INTENT(in) :: kstp ! ocean time-step index + ! + INTEGER :: jk ! dummy loop indice + !! --------------------------------------------------------------------- + IF( kstp == nit000 ) CALL iom_init( "nemo") ! iom_put initialization (must be done after nemo_init for AGRIF+XIOS+OASIS) + IF( kstp /= nit000 ) CALL day( kstp ) ! Calendar (day was already called at nit000 in day_init) + CALL iom_setkt( kstp - nit000 + 1, "nemo" ) ! say to iom that we are at time step kstp + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Update data, open boundaries, surface boundary condition (including sea-ice) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Ocean physics update (ua, va, ta, sa used as workspace) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points + CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points + CALL bn2( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency + CALL bn2( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency + + ! VERTICAL PHYSICS + CALL zdf_phy( kstp ) ! vertical physics update (bfr, avt, avs, avm + MLD) + + IF(.NOT.ln_linssh ) CALL ssh_nxt ( kstp ) ! after ssh (includes call to div_hor) + IF(.NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors + + IF(.NOT.ln_linssh ) CALL wzv ( kstp ) ! now cross-level velocity + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! diagnostics and outputs (ua, va, ta, sa used as workspace) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL dia_wri( kstp ) ! ocean model: outputs + CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) + + +#if defined key_top + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Passive Tracer Model + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL trc_stp( kstp ) ! time-stepping +#endif + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Active tracers (ua, va used as workspace) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + tsa(:,:,:,:) = 0._wp ! set tracer trends to zero + + CALL tra_sbc( kstp ) ! surface boundary condition + IF( ln_traqsr ) CALL tra_qsr( kstp ) ! penetrative solar radiation qsr + IF( ln_tradmp ) CALL tra_dmp( kstp ) ! internal damping trends- tracers + IF(.NOT.ln_linssh)CALL tra_adv( kstp ) ! horizontal & vertical advection + IF( ln_zdfosm ) CALL tra_osm( kstp ) ! OSMOSIS non-local tracer fluxes + CALL tra_zdf( kstp ) ! vertical mixing + CALL eos( tsn, rhd, rhop, gdept_0(:,:,:) ) ! now potential density for zdfmxl + IF( ln_zdfnpc ) CALL tra_npc( kstp ) ! applied non penetrative convective adjustment on (t,s) + CALL tra_nxt( kstp ) ! tracer fields at next time step + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Dynamics (ta, sa used as workspace) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ua(:,:,:) = 0._wp ! set dynamics trends to zero + va(:,:,:) = 0._wp + + IF( ln_dyndmp ) CALL dyn_dmp ( kstp ) ! internal damping trends- momentum + CALL dyn_cor_c1d( kstp ) ! vorticity term including Coriolis + IF( ln_zdfosm ) CALL dyn_osm ( kstp ) ! OSMOSIS non-local velocity fluxes + CALL dyn_zdf ( kstp ) ! vertical diffusion + CALL dyn_nxt ( kstp ) ! lateral velocity at next time step + IF(.NOT.ln_linssh)CALL ssh_swp ( kstp ) ! swap of sea surface height + + IF(.NOT.ln_linssh)CALL dom_vvl_sf_swp( kstp )! swap of vertical scale factors + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Control and restarts + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + CALL stp_ctl( kstp ) + IF( kstp == nit000 ) CALL iom_close( numror ) ! close input ocean restart file + IF( lrst_oce ) CALL rst_write( kstp ) ! write output ocean restart file + ! +#if defined key_iomput + IF( kstp == nitend .OR. nstop > 0 ) CALL xios_context_finalize() ! needed for XIOS + ! +#endif + END SUBROUTINE stp_c1d + +#else + !!---------------------------------------------------------------------- + !! Default key NO 1D Config + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE stp_c1d ( kt ) ! dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: kt + WRITE(*,*) 'stp_c1d: You should not have seen this print! error?', kt + END SUBROUTINE stp_c1d +#endif + + !!====================================================================== +END MODULE step_c1d diff --git a/NEMO_4.0.4_surge/src/OCE/CRS/README.rst b/NEMO_4.0.4_surge/src/OCE/CRS/README.rst new file mode 100644 index 0000000..8633dbe --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/README.rst @@ -0,0 +1,153 @@ +********************************** +On line biogeochemistry coarsening +********************************** + +.. todo:: + + + +.. contents:: + :local: + +Presentation +============ + +A capacity of coarsening physics to force a BGC model coupled to NEMO has been developed. +This capacity allow to run 'online' a BGC model coupled to OCE-SI3 with a lower resolution, +to reduce the CPU cost of the BGC model, while preserving the effective resolution of the dynamics. + +A presentation is available [attachment:crs_wiki_1.1.pdf​ here], where the methodology is presented. + +What is available and working for now in this version +===================================================== + +[To be completed] + +Description of the successful validation tests +============================================== + +[To be completed] + +What is not working yet with on line coarsening of biogeochemistry +================================================================== + +[To be completed] + +''should include precise explanation on MPI decomposition problems too'' + +How to set up and use on line biogeochemistry +============================================= + +Extract the on line biogeochemistry branch +------------------------------------------ + +To get the appropriate source code with the on line coarsening of biogeochemistry feature: + +.. code-block:: console + + $ svn co https://forge.ipsl.jussieu.fr/nemo/browser/NEMO/branches/2018/dev_r5003_MERCATOR6_CRS + + +How to activate coarsening? +--------------------------- + +To activate the coarsening, ``key_crs`` should be added to list of CPP keys. +This key will only activate the coarsening of dynamics. + +Some parameters are available in the namelist_cfg: + +.. code-block:: fortran + + ! passive tracer coarsened online simulations + !----------------------------------------------------------------------- + nn_factx = 3 ! Reduction factor of x-direction + nn_facty = 3 ! Reduction factor of y-direction + nn_msh_crs = 0 ! create (=1) a mesh file or not (=0) + nn_crs_kz = 3 ! 0, volume-weighted MEAN of KZ + ! 1, MAX of KZ + ! 2, MIN of KZ + ! 3, 10^(MEAN(LOG(KZ)) + ! 4, MEDIANE of KZ + ln_crs_wn = .false. ! wn coarsened (T) or computed using horizontal divergence ( F ) + ! ! + ln_crs_top = .true. !coarsening online for the bio + / + +- Only ``nn_factx = 3`` is available and the coarsening only works for grids with a T-pivot point for + the north-fold lateral boundary condition (ORCA025, ORCA12, ORCA36, ...). +- ``nn_msh_crs = 1`` will activate the generation of the coarsened grid meshmask. +- ``nn_crs_kz`` is the operator to coarsen the vertical mixing coefficient. +- ``ln_crs_wn`` + + - when ``key_vvl`` is activated, this logical has no effect; + the coarsened vertical velocities are computed using horizontal divergence. + - when ``key_vvl`` is not activated, + + - coarsened vertical velocities are computed using horizontal divergence (``ln_crs_wn = .false.``) + - or coarsened vertical velocities are computed with an average operator (``ln_crs_wn = .true.``) +- ``ln_crs_top = .true.``: should be activated to run BCG model in coarsened space; + so only works when ``key_top`` is in the cpp list and eventually ``key_pisces`` or ``key_my_trc``. + +Choice of operator to coarsene KZ +--------------------------------- + +A sensiblity test has been done with an Age tracer to compare the different operators. +The 3 and 4 options seems to provide the best results. + +Some results can be found [xxx here] + +Example of xml files to output coarsened variables with XIOS +------------------------------------------------------------ + +In the [attachment:iodef.xml iodef.xml] file, a "nemo" context is defined and +some variable defined in [attachment:file_def.xml file_def.xml] are writted on the ocean-dynamic grid. +To write variables on the coarsened grid, and in particular the passive tracers, +a "nemo_crs" context should be defined in [attachment:iodef.xml iodef.xml] and +the associated variable are listed in [attachment:file_crs_def.xml file_crs_def.xml ]. + +Passive tracers tracers initial conditions +------------------------------------------ + +When initial conditions are provided in NetCDF files, the field might be: + +- on the coarsened grid +- or they can be on another grid and + interpolated `on-the-fly <http://forge.ipsl.jussieu.fr/nemo/wiki/Users/SetupNewConfiguration/Weight-creator>`_. + Example of namelist for PISCES : + + .. code-block:: fortran + + !----------------------------------------------------------------------- + &namtrc_dta ! Initialisation from data input file + !----------------------------------------------------------------------- + ! + sn_trcdta(1) = 'DIC_REG1' , -12 , 'DIC' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(2) = 'ALK_REG1' , -12 , 'ALK' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(3) = 'O2_REG1' , -1 , 'O2' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(5) = 'PO4_REG1' , -1 , 'PO4' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(7) = 'Si_REG1' , -1 , 'Si' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(10) = 'DOC_REG1' , -12 , 'DOC' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(14) = 'Fe_REG1' , -12 , 'Fe' , .false. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + sn_trcdta(23) = 'NO3_REG1' , -1 , 'NO3' , .true. , .true. , 'yearly' , 'reshape_REG1toeORCA075_bilin.nc' , '' , '' + rn_trfac(1) = 1.0e-06 ! multiplicative factor + rn_trfac(2) = 1.0e-06 ! - - - - + rn_trfac(3) = 44.6e-06 ! - - - - + rn_trfac(5) = 122.0e-06 ! - - - - + rn_trfac(7) = 1.0e-06 ! - - - - + rn_trfac(10) = 1.0e-06 ! - - - - + rn_trfac(14) = 1.0e-06 ! - - - - + rn_trfac(23) = 7.6e-06 ! - - - - + + cn_dir = './' ! root directory for the location of the data files + +PISCES forcing files +-------------------- + +They might be on the coarsened grid. + +Perspectives +============ + +For the future, a few options are on the table to implement coarsening for biogeochemistry in 4.0 and +future releases. +Those will be discussed in Autumn 2018 diff --git a/NEMO_4.0.4_surge/src/OCE/CRS/crs.F90 b/NEMO_4.0.4_surge/src/OCE/CRS/crs.F90 new file mode 100644 index 0000000..4d28acf --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/crs.F90 @@ -0,0 +1,346 @@ +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 :: nlci_full, nlcj_full !: i-, j-dimension of local or sub domain on parent grid + INTEGER :: nldi_full, nldj_full !: starting indices of internal sub-domain on parent grid + INTEGER :: nlei_full, nlej_full !: ending indices of internal sub-domain on parent grid + INTEGER :: nlci_crs, nlcj_crs !: i-, j-dimension of local or sub domain on coarse grid + INTEGER :: nldi_crs, nldj_crs !: starting indices of internal sub-domain on coarse grid + INTEGER :: nlei_crs, nlej_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 :: nreci_full, nrecj_full + INTEGER :: nreci_crs, nrecj_crs + !cc + INTEGER :: noea_full, nowe_full !: index of the local neighboring processors in + INTEGER :: noso_full, nono_full !: east, west, south and north directions + INTEGER :: npne_full, npnw_full !: index of north east and north west processor + INTEGER :: npse_full, npsw_full !: index of south east and south west processor + INTEGER :: nbne_full, nbnw_full !: logical of north east & north west processor + INTEGER :: nbse_full, nbsw_full !: logical of south east & south west processor + INTEGER :: nidom_full !: ??? + INTEGER :: nproc_full !:number for local processor + INTEGER :: nbondi_full, nbondj_full !: mark of i- and j-direction local boundaries + INTEGER :: noea_crs, nowe_crs !: index of the local neighboring processors in + INTEGER :: noso_crs, nono_crs !: east, west, south and north directions + INTEGER :: npne_crs, npnw_crs !: index of north east and north west processor + INTEGER :: npse_crs, npsw_crs !: index of south east and south west processor + INTEGER :: nbne_crs, nbnw_crs !: logical of north east & north west processor + INTEGER :: nbse_crs, nbsw_crs !: logical of south east & south west processor + INTEGER :: nidom_crs !: ??? + INTEGER :: nproc_crs !:number for local processor + INTEGER :: nbondi_crs, nbondj_crs !: mark of i- and j-direction local boundaries + + + 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 :: nlcit_crs, nlcit_full !: dimensions of every subdomain + INTEGER, DIMENSION(:), ALLOCATABLE :: nldit_crs, nldit_full !: first, last indoor index for each i-domain + INTEGER, DIMENSION(:), ALLOCATABLE :: nleit_crs, nleit_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 :: nlcjt_crs, nlcjt_full !: dimensions of every subdomain + INTEGER, DIMENSION(:), ALLOCATABLE :: nldjt_crs, nldjt_full !: first, last indoor index for each i-domain + INTEGER, DIMENSION(:), ALLOCATABLE :: nlejt_crs, nlejt_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 :: tmask_i_crs, rnfmsk_crs, tpol_crs, fpol_crs + + ! REAL(wp), DIMENSION(:,:), ALLOCATABLE :: tmask_i_crs, tpol, fpol + + ! 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$ + !! 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( tmask_i_crs(jpi_crs,jpj_crs) , rnfmsk_crs(jpi_crs,jpj_crs), & + & tpol_crs(jpiglo_crs,jpjglo_crs), fpol_crs(jpiglo_crs,jpjglo_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) , nlcit_crs (jpnij) , nldit_crs (jpnij) , nleit_crs (jpnij), & + & nimppt_full(jpnij) , nlcit_full(jpnij) , nldit_full(jpnij) , nleit_full(jpnij), & + njmppt_crs (jpnij) , nlcjt_crs (jpnij) , nldjt_crs (jpnij) , nlejt_crs (jpnij), & + & njmppt_full(jpnij) , nlcjt_full(jpnij) , nldjt_full(jpnij) , nlejt_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(nlej_crs) , mje_crs(nlej_crs), mis_crs(nlei_crs) , mie_crs(nlei_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 + + nlci = nlci_full + nlcj = nlcj_full + nldi = nldi_full + nldj = nldj_full + nlei = nlei_full + nlej = nlej_full + nimpp = nimpp_full + njmpp = njmpp_full + + nlcit(:) = nlcit_full(:) + nldit(:) = nldit_full(:) + nleit(:) = nleit_full(:) + nimppt(:) = nimppt_full(:) + nlcjt(:) = nlcjt_full(:) + nldjt(:) = nldjt_full(:) + nlejt(:) = nlejt_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 + + + nlci = nlci_crs + nlcj = nlcj_crs + nldi = nldi_crs + nlei = nlei_crs + nlej = nlej_crs + nldj = nldj_crs + nimpp = nimpp_crs + njmpp = njmpp_crs + + nlcit(:) = nlcit_crs(:) + nldit(:) = nldit_crs(:) + nleit(:) = nleit_crs(:) + nimppt(:) = nimppt_crs(:) + nlcjt(:) = nlcjt_crs(:) + nldjt(:) = nldjt_crs(:) + nlejt(:) = nlejt_crs(:) + njmppt(:) = njmppt_crs(:) + ! + END SUBROUTINE dom_grid_crs + + !!====================================================================== +END MODULE crs + diff --git a/NEMO_4.0.4_surge/src/OCE/CRS/crsdom.F90 b/NEMO_4.0.4_surge/src/OCE/CRS/crsdom.F90 new file mode 100644 index 0000000..194e5a7 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/crsdom.F90 @@ -0,0 +1,2274 @@ +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 and to get jperio + 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$ + !! 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( nldj_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, nlei_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 + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,je_2 ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,2,jk) = 1.0 + + zmask = 0.0 + zmask = SUM(umask(ijie,ij:je_2,jk)) + IF ( zmask > 0.0 ) umask_crs(ji,2,jk) = 1.0 + + fmask_crs(ji,je_2,jk) = fmask(ijie,2,jk) + ENDDO + ENDDO + ! + DO jk = 1, jpkm1 + DO ji = 2, nlei_crs + ijis = mis_crs(ji) ; ijie = mie_crs(ji) + DO jj = 3, nlej_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 + + zmask = 0.0 + zmask = SUM( vmask(ijis:ijie,ijje ,jk) ) + IF ( zmask > 0.0 ) vmask_crs(ji,jj,jk) = 1.0 + + zmask = 0.0 + zmask = SUM( umask(ijie ,ijjs:ijje,jk) ) + IF ( zmask > 0.0 ) umask_crs(ji,jj,jk) = 1.0 + + fmask_crs(ji,jj,jk) = fmask(ijie,ijje,jk) + ENDDO + ENDDO + ENDDO + + ! + CALL crs_lbc_lnk( tmask_crs, 'T', 1.0 ) + CALL crs_lbc_lnk( vmask_crs, 'V', 1.0 ) + CALL crs_lbc_lnk( umask_crs, 'U', 1.0 ) + CALL crs_lbc_lnk( fmask_crs, 'F', 1.0 ) + ! + 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 = nldj_crs, nlej_crs + ijjs = mjs_crs(jj) + mybinctr + DO ji = 2, nlei_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 = nldj_crs, nlej_crs + ijjs = mjs_crs(jj) + mybinctr + DO ji = 2, nlei_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 = nldj_crs, nlej_crs + ijjs = mjs_crs(jj) + DO ji = 2, nlei_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 = nldj_crs, nlej_crs + ijjs = mjs_crs(jj) + DO ji = 2, nlei_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 ) + CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 ) + + ! 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, nlei_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, nlei_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(wp), DIMENSION(jpi,jpj) , INTENT(in) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(wp), 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, nlei_crs + ijie = mie_crs(ji) + DO jj = nldj_crs, nlej_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, pfillval=1.0 ) + CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0, pfillval=1.0 ) + + 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(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: p_e1 ! Parent grid U,V scale factors (e1) + REAL(wp), 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( nldj_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 ) + CALL crs_lbc_lnk( p_fld2_crs, cd_type, 1.0 ) + ! + ! + 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(wp), 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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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(wp), 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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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( nldj_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(wp), 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( nldj_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, pfillval=1.0 ) + CALL crs_lbc_lnk( p_e3_max_crs, cd_type, 1.0, pfillval=1.0 ) + ! + ! + 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( nldj_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, pfillval=1.0 ) + CALL crs_lbc_lnk( p_surf_crs_msk, cd_type, 1.0, pfillval=1.0 ) + + 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 + nlci_crs = jpi_crs + nlcj_crs = jpj_crs + nldi_crs = 1 + nldj_crs = 1 + nlei_crs = jpi_crs + nlej_crs = jpj_crs + ELSE + ! Initialisation of most local variables - + nimpp_crs = 1 + njmpp_crs = 1 + nlci_crs = jpi_crs + nlcj_crs = jpj_crs + nldi_crs = 1 + nldj_crs = 1 + nlei_crs = jpi_crs + nlej_crs = jpj_crs + + ! Calculs suivant une découpage en j + DO jn = 1, jpnij, jpni + IF( jn < ( jpnij - jpni + 1 ) ) THEN + nlejt_crs(jn) = AINT( REAL( ( jpjglo - (njmppt(jn ) - 1) ) / nn_facty, wp ) ) & + & - AINT( REAL( ( jpjglo - (njmppt(jn+jpni) - 1) ) / nn_facty, wp ) ) + ELSE + nlejt_crs(jn) = AINT( REAL( nlejt(jn) / nn_facty, wp ) ) + 1 + ENDIF + IF( noso < 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 + SELECT CASE( ibonjt(jn) ) + CASE ( -1 ) + IF( MOD( jpjglo - njmppt(jn), nn_facty) > 0 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 + nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls + nldjt_crs(jn) = nldjt(jn) + + CASE ( 0 ) + + nldjt_crs(jn) = nldjt(jn) + IF( nldjt(jn) == 1 ) nlejt_crs(jn) = nlejt_crs(jn) + 1 + nlejt_crs(jn) = nlejt_crs(jn) + nn_hls + nlcjt_crs(jn) = nlejt_crs(jn) + nn_hls + + CASE ( 1, 2 ) + + nlejt_crs(jn) = nlejt_crs(jn) + nn_hls + nlcjt_crs(jn) = nlejt_crs(jn) + nldjt_crs(jn) = nldjt(jn) + + CASE DEFAULT + CALL ctl_stop( 'STOP', 'error from crs_dom_def, you should not be there (1) ...' ) + END SELECT + IF( nlcjt_crs(jn) > jpj_crs ) jpj_crs = jpj_crs + 1 + + IF(nldjt_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 + nlejt_crs(jj) = nlejt_crs(jn) + nlcjt_crs(jj) = nlcjt_crs(jn) + nldjt_crs(jj) = nldjt_crs(jn) + njmppt_crs(jj)= njmppt_crs(jn) + ENDDO + ENDDO + nlej_crs = nlejt_crs(nproc + 1) + nlcj_crs = nlcjt_crs(nproc + 1) + nldj_crs = nldjt_crs(nproc + 1) + njmpp_crs = njmppt_crs(nproc + 1) + + ! Calcul suivant un decoupage en i + DO jn = 1, jpni + IF( jn == 1 ) THEN + nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) + ELSE + nleit_crs(jn) = AINT( REAL( ( nimppt(jn ) - 1 + nlcit(jn ) ) / nn_factx, wp) ) & + & - AINT( REAL( ( nimppt(jn-1) - 1 + nlcit(jn-1) ) / nn_factx, wp) ) + ENDIF + + SELECT CASE( ibonit(jn) ) + CASE ( -1 ) + nleit_crs(jn) = nleit_crs(jn) + nn_hls + nlcit_crs(jn) = nleit_crs(jn) + nn_hls + nldit_crs(jn) = nldit(jn) + + CASE ( 0 ) + nleit_crs(jn) = nleit_crs(jn) + nn_hls + nlcit_crs(jn) = nleit_crs(jn) + nn_hls + nldit_crs(jn) = nldit(jn) + + CASE ( 1, 2 ) + IF( MOD( jpiglo - nimppt(jn), nn_factx) > 0 ) nleit_crs(jn) = nleit_crs(jn) + 1 + nleit_crs(jn) = nleit_crs(jn) + nn_hls + nlcit_crs(jn) = nleit_crs(jn) + nldit_crs(jn) = nldit(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 + nleit_crs(jj) = nleit_crs(jn) + nlcit_crs(jj) = nlcit_crs(jn) + nldit_crs(jj) = nldit_crs(jn) + nimppt_crs(jj)= nimppt_crs(jn) + ENDDO + ENDDO + + nlei_crs = nleit_crs(nproc + 1) + nlci_crs = nlcit_crs(nproc + 1) + nldi_crs = nldit_crs(nproc + 1) + nimpp_crs = nimppt_crs(nproc + 1) + + 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 + + nlcj_full = nlcj + nlci_full = nlci + nldi_full = nldi + nldj_full = nldj + nlei_full = nlei + nlej_full = nlej + nimpp_full = nimpp + njmpp_full = njmpp + + nlcit_full(:) = nlcit(:) + nldit_full(:) = nldit(:) + nleit_full(:) = nleit(:) + nimppt_full(:) = nimppt(:) + nlcjt_full(:) = nlcjt(:) + nldjt_full(:) = nldjt(:) + nlejt_full(:) = nlejt(:) + 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,*) ' nproc = ' , nproc + WRITE(numout,*) ' nlci = ' , nlci + WRITE(numout,*) ' nlcj = ' , nlcj + WRITE(numout,*) ' nldi = ' , nldi + WRITE(numout,*) ' nldj = ' , nldj + WRITE(numout,*) ' nlei = ' , nlei + WRITE(numout,*) ' nlej = ' , nlej + WRITE(numout,*) ' nlei_full=' , nlei_full + WRITE(numout,*) ' nldi_full=' , nldi_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, nlej_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, nlei_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(nlci_crs - 1) + njstr = mjs_crs(3) ; njend = mjs_crs(nlcj_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) ; 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) ; mbku_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + zmbk(:,:) = REAL( mbkv_crs(:,:), wp ) ; CALL crs_lbc_lnk(zmbk,'V',1.0) ; mbkv_crs (:,:) = MAX( NINT( zmbk(:,:) ), 1 ) + ! + END SUBROUTINE crs_dom_bat + + +END MODULE crsdom diff --git a/NEMO_4.0.4_surge/src/OCE/CRS/crsdomwri.F90 b/NEMO_4.0.4_surge/src/OCE/CRS/crsdomwri.F90 new file mode 100644 index 0000000..506d073 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/crsdomwri.F90 @@ -0,0 +1,237 @@ +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$ + !! 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 + INTEGER :: iif, iil, ijf, ijl + 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 ) + + + tmask_i_crs(:,:) = tmask_crs(:,:,1) + iif = nn_hls + iil = nlci_crs - nn_hls + 1 + ijf = nn_hls + ijl = nlcj_crs - nn_hls + 1 + + tmask_i_crs( 1:iif , : ) = 0._wp + tmask_i_crs(iil:jpi_crs, : ) = 0._wp + tmask_i_crs( : , 1:ijf ) = 0._wp + tmask_i_crs( : ,ijl:jpj_crs) = 0._wp + + + tpol_crs(1:jpiglo_crs,:) = 1._wp + fpol_crs(1:jpiglo_crs,:) = 1._wp + IF( jperio == 3 .OR. jperio == 4 ) THEN + tpol_crs(jpiglo_crs/2+1:jpiglo_crs,:) = 0._wp + fpol_crs( 1 :jpiglo_crs,:) = 0._wp + IF( mjg_crs(nlej_crs) == jpiglo_crs ) THEN + DO ji = iif+1, iil-1 + tmask_i_crs(ji,nlej_crs-1) = tmask_i_crs(ji,nlej_crs-1) & + & * tpol_crs(mig_crs(ji),1) + ENDDO + ENDIF + ENDIF + IF( jperio == 5 .OR. jperio == 6 ) THEN + tpol_crs( 1 :jpiglo_crs,:)=0._wp + fpol_crs(jpiglo_crs/2+1:jpiglo_crs,:)=0._wp + ENDIF + + CALL iom_rstput( 0, 0, inum, 'tmaskutil', tmask_i_crs, ktype = jp_i1 ) + ! ! unique point mask + 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 fs_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. ) ; CALL crs_lbc_lnk( zdepv,'V', 1. ) + ! + 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(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! 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 * jpj_crs * ( narea - 1 ) + 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. ) ! apply boundary conditions + lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed + ! + puniq(:,:) = 1. ! default definition + ! fill only the inner part of the cpu with llbl converted into real + puniq(nldi_crs:nlei_crs,nldj_crs:nlej_crs) = REAL( COUNT( lldbl(nldi_crs:nlei_crs,nldj_crs:nlej_crs,:), dim = 3 ) , wp ) + ! + END SUBROUTINE dom_uniq_crs + + !!====================================================================== + +END MODULE crsdomwri + + diff --git a/NEMO_4.0.4_surge/src/OCE/CRS/crsfld.F90 b/NEMO_4.0.4_surge/src/OCE/CRS/crsfld.F90 new file mode 100644 index 0000000..e2aabba --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/crsfld.F90 @@ -0,0 +1,250 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_fld( kt ) + !!--------------------------------------------------------------------- + !! *** 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 :: 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 + ze3t(:,:,:) = e3t_n(:,:,:) + ze3u(:,:,:) = e3u_n(:,:,:) + ze3v(:,:,:) = e3v_n(:,:,:) + ze3w(:,:,:) = e3w_n(:,:,:) + + 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(:,:,:) = tsn(:,:,:,jp_tem) ; zt_crs(:,:,:) = 0._wp + CALL crs_dom_ope( zt, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) + 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(:,:,:) = tsn(:,:,:,jp_sal) ; zs_crs(:,:,:) = 0._wp + CALL crs_dom_ope( zs, 'VOL', 'T', tmask, zs_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) + 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( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zt(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) + zs(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) + END DO + END DO + END DO + CALL crs_dom_ope( zt, 'SUM', 'U', umask, zt_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) + CALL crs_dom_ope( zs, 'SUM', 'U', umask, zs_crs, p_e12=e2u, p_e3=ze3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) + + 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( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) + ! + zt(:,:,:) = 0._wp ; zs(:,:,:) = 0._wp ; zt_crs(:,:,:) = 0._wp ; zs_crs(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zt(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) + zs(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) + END DO + END DO + END DO + CALL crs_dom_ope( zt, 'SUM', 'V', vmask, zt_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) + CALL crs_dom_ope( zs, 'SUM', 'V', vmask, zs_crs, p_e12=e1v, p_e3=ze3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) + + 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( "eken") ) THEN ! kinetic energy + z3d(:,:,jk) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zztmp = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + z3d(ji,jj,jk) = 0.25_wp * zztmp * ( & + & un(ji-1,jj,jk)**2 * e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) & + & + un(ji ,jj,jk)**2 * e2u(ji ,jj) * e3u_n(ji ,jj,jk) & + & + vn(ji,jj-1,jk)**2 * e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) & + & + vn(ji,jj ,jk)**2 * e1v(ji,jj ) * e3v_n(ji,jj ,jk) ) + END DO + END DO + END DO + CALL lbc_lnk( 'crsfld', z3d, 'T', 1. ) + ! + CALL crs_dom_ope( z3d, 'VOL', 'T', tmask, zt_crs, p_e12=e1e2t, p_e3=ze3t, psgn=1.0 ) + CALL iom_put( "eken", 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 ) + ! + CALL iom_put( "hdiv", hdivn_crs ) + + + ! W-velocity + IF( ln_crs_wn ) THEN + CALL crs_dom_ope( wn, 'SUM', 'W', tmask, wn_crs, p_e12=e1e2t, p_surf_crs=e1e2w_msk, psgn=1.0 ) + ! CALL crs_dom_ope( wn, '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 ) + CALL crs_dom_ope( avs, 'VOL', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) + CASE ( 1 ) + CALL crs_dom_ope( avt, 'MAX', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) + CALL crs_dom_ope( avs, 'MAX', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) + CASE ( 2 ) + CALL crs_dom_ope( avt, 'MIN', 'W', tmask, avt_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) + CALL crs_dom_ope( avs, 'MIN', 'W', tmask, avs_crs, p_e12=e1e2t, p_e3=ze3w, psgn=1.0 ) + 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( sshn , 'VOL', 'T', tmask, sshn_crs , p_e12=e1e2t, p_e3=ze3t , psgn=1.0 ) + CALL crs_dom_ope( utau , 'SUM', 'U', umask, utau_crs , p_e12=e2u , p_surf_crs=e2u_crs , psgn=1.0 ) + CALL crs_dom_ope( vtau , 'SUM', 'V', vmask, vtau_crs , p_e12=e1v , p_surf_crs=e1v_crs , psgn=1.0 ) + CALL crs_dom_ope( wndm , 'SUM', 'T', tmask, wndm_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) + CALL crs_dom_ope( rnf , 'MAX', 'T', tmask, rnf_crs , psgn=1.0 ) + CALL crs_dom_ope( qsr , 'SUM', 'T', tmask, qsr_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) + CALL crs_dom_ope( emp_b, 'SUM', 'T', tmask, emp_b_crs, p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) + CALL crs_dom_ope( emp , 'SUM', 'T', tmask, emp_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) + CALL crs_dom_ope( sfx , 'SUM', 'T', tmask, sfx_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) + CALL crs_dom_ope( fr_i , 'SUM', 'T', tmask, fr_i_crs , p_e12=e1e2t, p_surf_crs=e1e2t_crs, psgn=1.0 ) + + 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/NEMO_4.0.4_surge/src/OCE/CRS/crsini.F90 b/NEMO_4.0.4_surge/src/OCE/CRS/crsini.F90 new file mode 100644 index 0000000..6bd45b5 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/crsini.F90 @@ -0,0 +1,243 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE crs_init + !!------------------------------------------------------------------- + !! *** 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 :: 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 + !--------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run + READ ( numnam_ref, namcrs, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcrs in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run + 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,*) ' wn coarsened or computed using hdivn 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, e2u, 'U', e1u_crs, e2u_crs ) + CALL crs_dom_hgr( e1v, 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 + + ! + ze3t(:,:,:) = e3t_n(:,:,:) + ze3u(:,:,:) = e3u_n(:,:,:) + ze3v(:,:,:) = e3v_n(:,:,:) + ze3w(:,:,:) = e3w_n(:,:,:) + + ! 3.d.2 Surfaces + CALL crs_dom_sfc( tmask, 'W', e1e2w_crs, e1e2w_msk, p_e1=e1t, p_e2=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 ) + + 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, 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( 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 ) + CALL crs_dom_ope( gdepw_0, 'MAX', 'W', tmask, gdepw_crs, p_e3=ze3w, psgn=1.0 ) + + + !--------------------------------------------------------- + ! 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/NEMO_4.0.4_surge/src/OCE/CRS/crslbclnk.F90 b/NEMO_4.0.4_surge/src/OCE/CRS/crslbclnk.F90 new file mode 100644 index 0000000..9a3a52d --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/CRS/crslbclnk.F90 @@ -0,0 +1,89 @@ +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$ + !! 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, 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, 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/NEMO_4.0.4_surge/src/OCE/DIA/dia25h.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/dia25h.F90 new file mode 100644 index 0000000..5bb7e54 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/dia25h.F90 @@ -0,0 +1,270 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_25h_init + !!--------------------------------------------------------------------------- + !! *** ROUTINE dia_25h_init *** + !! + !! ** Purpose: Initialization of 25h mean namelist + !! + !! ** Method : Read namelist + !!--------------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + INTEGER :: ierror ! Local integer for memory allocation + ! + NAMELIST/nam_dia25h/ ln_dia25h + !!---------------------------------------------------------------------- + ! + REWIND ( numnam_ref ) ! Read Namelist nam_dia25h in reference namelist : 25hour mean diagnostics + READ ( numnam_ref, nam_dia25h, IOSTAT=ios, ERR= 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_dia25h in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist nam_dia25h in configuration namelist 25hour diagnostics + 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 (jpi,jpj,jpk), sn_25h (jpi,jpj,jpk), sshn_25h(jpi,jpj) , & + & un_25h (jpi,jpj,jpk), vn_25h (jpi,jpj,jpk), wn_25h(jpi,jpj,jpk), & + & avt_25h(jpi,jpj,jpk), avm_25h(jpi,jpj,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(jpi,jpj,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(jpi,jpj,jpk), rmxln_25h(jpi,jpj,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) + tn_25h (:,:,:) = tsb (:,:,:,jp_tem) + sn_25h (:,:,:) = tsb (:,:,:,jp_sal) + sshn_25h(:,:) = sshb(:,:) + un_25h (:,:,:) = ub (:,:,:) + vn_25h (:,:,:) = vb (:,:,:) + avt_25h (:,:,:) = avt (:,:,:) + avm_25h (:,:,:) = avm (:,:,:) + IF( ln_zdftke ) THEN + en_25h(:,:,:) = en(:,:,:) + ENDIF + IF( ln_zdfgls ) THEN + en_25h (:,:,:) = en (:,:,:) + rmxln_25h(:,:,:) = hmxl_n(:,:,:) + ENDIF +#if defined key_si3 + CALL ctl_stop('STOP', 'dia_25h not setup yet to do tidemean ice') +#endif + ! + END SUBROUTINE dia_25h_init + + + SUBROUTINE dia_25h( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk + INTEGER :: iyear0, nimonth0,iday0 ! start year,imonth,day + LOGICAL :: ll_print = .FALSE. ! =T print and flush numout + REAL(wp) :: zsto, zout, zmax, zjulian, zmdi ! local scalars + INTEGER :: i_steps ! no of timesteps per hour + REAL(wp), DIMENSION(jpi,jpj ) :: zw2d, un_dm, vn_dm ! workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! workspace + REAL(wp), DIMENSION(jpi,jpj,3) :: zwtmb ! workspace + !!---------------------------------------------------------------------- + + ! 0. Initialisation + ! ----------------- + ! Define frequency of summing to create 25 h mean + IF( MOD( 3600,NINT(rdt) ) == 0 ) THEN + i_steps = 3600/NINT(rdt) + ELSE + CALL ctl_stop('STOP', 'dia_wri_tide: timestep must give MOD(3600,rdt) = 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 + wn_25h(:,:,:) = wn(:,:,:) + 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 + + tn_25h (:,:,:) = tn_25h (:,:,:) + tsn (:,:,:,jp_tem) + sn_25h (:,:,:) = sn_25h (:,:,:) + tsn (:,:,:,jp_sal) + sshn_25h(:,:) = sshn_25h(:,:) + sshn(:,:) + un_25h (:,:,:) = un_25h (:,:,:) + un (:,:,:) + vn_25h (:,:,:) = vn_25h (:,:,:) + vn (:,:,:) + wn_25h (:,:,:) = wn_25h (:,:,:) + wn (:,:,:) + avt_25h (:,:,:) = avt_25h (:,:,:) + avt (:,:,:) + avm_25h (:,:,:) = avm_25h (:,:,:) + avm (:,:,:) + IF( ln_zdftke ) THEN + en_25h(:,:,:) = en_25h (:,:,:) + en(:,:,:) + ENDIF + IF( ln_zdfgls ) THEN + en_25h (:,:,:) = en_25h (:,:,:) + en (:,:,:) + rmxln_25h(:,:,:) = rmxln_25h(:,:,:) + hmxl_n(:,:,:) + 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) + zw3d(:,:,:) = tn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put("temper25h", zw3d) ! potential temperature + zw3d(:,:,:) = sn_25h(:,:,:)*tmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put( "salin25h", zw3d ) ! salinity + zw2d(:,:) = sshn_25h(:,:)*tmask(:,:,1) + zmdi*(1.0-tmask(:,:,1)) + 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) + zw3d(:,:,:) = un_25h(:,:,:)*umask(:,:,:) + zmdi*(1.0-umask(:,:,:)) + CALL iom_put("vozocrtx25h", zw3d) ! i-current + zw3d(:,:,:) = vn_25h(:,:,:)*vmask(:,:,:) + zmdi*(1.0-vmask(:,:,:)) + CALL iom_put("vomecrty25h", zw3d ) ! j-current + zw3d(:,:,:) = wn_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put("vovecrtz25h", zw3d ) ! k-current + ! Write vertical physics + zw3d(:,:,:) = avt_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put("avt25h", zw3d ) ! diffusivity + zw3d(:,:,:) = avm_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put("avm25h", zw3d) ! viscosity + IF( ln_zdftke ) THEN + zw3d(:,:,:) = en_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put("tke25h", zw3d) ! tke + ENDIF + IF( ln_zdfgls ) THEN + zw3d(:,:,:) = en_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put("tke25h", zw3d) ! tke + zw3d(:,:,:) = rmxln_25h(:,:,:)*wmask(:,:,:) + zmdi*(1.0-tmask(:,:,:)) + CALL iom_put( "mxln25h",zw3d) + ENDIF + ! + ! After the write reset the values to cnt=1 and sum values equal current value + tn_25h (:,:,:) = tsn (:,:,:,jp_tem) + sn_25h (:,:,:) = tsn (:,:,:,jp_sal) + sshn_25h(:,:) = sshn(:,:) + un_25h (:,:,:) = un (:,:,:) + vn_25h (:,:,:) = vn (:,:,:) + wn_25h (:,:,:) = wn (:,:,:) + avt_25h (:,:,:) = avt (:,:,:) + avm_25h (:,:,:) = avm (:,:,:) + IF( ln_zdftke ) THEN + en_25h(:,:,:) = en(:,:,:) + ENDIF + IF( ln_zdfgls ) THEN + en_25h (:,:,:) = en (:,:,:) + rmxln_25h(:,:,:) = hmxl_n(:,:,:) + 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/NEMO_4.0.4_surge/src/OCE/DIA/diaar5.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diaar5.F90 new file mode 100644 index 0000000..aa00206 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diaar5.F90 @@ -0,0 +1,444 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ar5 *** + !! + !! ** Purpose : compute and output some AR5 diagnostics + !!---------------------------------------------------------------------- + ! + INTEGER, INTENT( in ) :: kt ! ocean time-step 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(:,:) :: zpe, z2d ! 2D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zrhd , ztpot ! 3D workspace + 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(:,:) * sshn(:,:) + 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_n(:,:,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' , rau0 * e3t_n(:,:,:) * tmask(:,:,:) ) ! ocean mass + ENDIF + ! + IF( iom_use( 'e3tb' ) ) THEN ! bottom layer thickness + DO jj = 1, jpj + DO ji = 1, jpi + ikb = mbkt(ji,jj) + z2d(ji,jj) = e3t_n(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', zarea_ssh(:,:) ) + zvol = vol0 + zvolssh + + CALL iom_put( 'voltot', zvol ) + CALL iom_put( 'sshtot', zvolssh / area_tot ) + CALL iom_put( 'sshdyn', sshn(:,:) - (zvolssh / area_tot) ) + ! + ENDIF + + IF( iom_use( 'botpres' ) .OR. iom_use( 'sshthster' ) .OR. iom_use( 'sshsteric' ) ) THEN + ! + ztsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) ! thermosteric ssh + ztsn(:,:,:,jp_sal) = sn0(:,:,:) + CALL eos( ztsn, zrhd, gdept_n(:,:,:) ) ! now in situ density using initial salinity + ! + zbotpres(:,:) = 0._wp ! no atmospheric surface pressure, levitating sea-ice + DO jk = 1, jpkm1 + zbotpres(:,:) = zbotpres(:,:) + e3t_n(:,:,jk) * zrhd(:,:,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) + sshn(ji,jj) * zrhd(ji,jj,iks) + riceload(ji,jj) + END DO + END DO + ELSE + zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * 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_n(:,:,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) + sshn(ji,jj) * rhd(ji,jj,iks) + riceload(ji,jj) + END DO + END DO + ELSE + zbotpres(:,:) = zbotpres(:,:) + sshn(:,:) * 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 = rau0 * grav * 1.e-4_wp ! recover pressure from pressure anomaly and cover to dbar = 1.e4 Pa + zbotpres(:,:) = zztmp * ( zbotpres(:,:) + sshn(:,:) + thick0(:,:) ) + CALL iom_put( 'botpres', zbotpres ) + ! + 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 = 1, jpj + DO ji = 1, jpi + zztmp = e1e2t(ji,jj) * e3t_n(ji,jj,jk) + ztsn(ji,jj,1,jp_tem) = ztsn(ji,jj,1,jp_tem) + zztmp * tsn(ji,jj,jk,jp_tem) + ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zztmp * tsn(ji,jj,jk,jp_sal) + ENDDO + ENDDO + ENDDO + + 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) * tsn(ji,jj,iks,jp_tem) + ztsn(ji,jj,1,jp_sal) = ztsn(ji,jj,1,jp_sal) + zarea_ssh(ji,jj) * tsn(ji,jj,iks,jp_sal) + END DO + END DO + ELSE + ztsn(:,:,1,jp_tem) = ztsn(:,:,1,jp_tem) + zarea_ssh(:,:) * tsn(:,:,1,jp_tem) + ztsn(:,:,1,jp_sal) = ztsn(:,:,1,jp_sal) + zarea_ssh(:,:) * tsn(:,:,1,jp_sal) + END IF + ENDIF + ! + ztemp = glob_sum( 'diaar5', ztsn(:,:,1,jp_tem) ) + zsal = glob_sum( 'diaar5', ztsn(:,:,1,jp_sal) ) + zmass = rau0 * ( 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( tsn(:,:,jk,jp_tem), tsn(:,:,jk,jp_sal) ) + 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_n(:,:,jk) * ztpot(:,:,jk) + END DO + ztemp = glob_sum( 'diaar5', z2d(:,:) ) + 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 = 1, jpj + DO ji = 1, jpi ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + rau0 * e3t_n(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(:,:) * tsn(:,:,1,jp_tem) ) + 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 = 1, jpj + DO ji = 1, jpi + IF( rn2(ji,jj,jk) > 0._wp ) THEN + zrw = ( gdept_n(ji,jj,jk) - gdepw_n(ji,jj,jk) ) / e3w_n(ji,jj,jk) + ! + 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 * (tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) & + & - avs(ji,jj,jk) * zbw * (tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) ) + ENDIF + END DO + END DO + END DO + ELSE + DO jk = 1, jpk + DO ji = 1, jpi + DO jj = 1, jpj + zpe(ji,jj) = zpe(ji,jj) + avt(ji,jj,jk) * MIN(0._wp,rn2(ji,jj,jk)) * rau0 * e3w_n(ji,jj,jk) + 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( zrhd ) + DEALLOCATE( ztsn ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_ar5') + ! + END SUBROUTINE dia_ar5 + + + SUBROUTINE dia_ar5_hst( ktra, cptr, pua, pva ) + !!---------------------------------------------------------------------- + !! *** 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(jpi,jpj,jpk), INTENT(in) :: pua ! 3D input array of advection/diffusion + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion + ! + INTEGER :: ji, jj, jk + REAL(wp), DIMENSION(jpi,jpj) :: z2d + + + z2d(:,:) = pua(:,:,1) + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + pua(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'diaar5', z2d, 'U', -1. ) + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'uadv_heattr' , rau0_rcp * z2d ) ! advective heat transport in i-direction + IF( ktra == jp_sal ) CALL iom_put( 'uadv_salttr' , rau0 * z2d ) ! advective salt transport in i-direction + ENDIF + IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'udiff_heattr' , rau0_rcp * z2d ) ! diffusive heat transport in i-direction + IF( ktra == jp_sal ) CALL iom_put( 'udiff_salttr' , rau0 * z2d ) ! diffusive salt transport in i-direction + ENDIF + ! + z2d(:,:) = pva(:,:,1) + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + pva(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'diaar5', z2d, 'V', -1. ) + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'vadv_heattr' , rau0_rcp * z2d ) ! advective heat transport in j-direction + IF( ktra == jp_sal ) CALL iom_put( 'vadv_salttr' , rau0 * z2d ) ! advective salt transport in j-direction + ENDIF + IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) CALL iom_put( 'vdiff_heattr' , rau0_rcp * z2d ) ! diffusive heat transport in j-direction + IF( ktra == jp_sal ) CALL iom_put( 'vdiff_salttr' , rau0 * 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( '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 = 1, jpj ! interpolation of salinity at the last ocean level (i.e. the partial step) + DO ji = 1, jpi + 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', zvol0 ) + 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_data, 'vosaline' , zsaldta(:,:,:,1), 1 ) + CALL iom_get ( inum, jpdom_data, '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 = 1, jpj ! interpolation of salinity at the last ocean level (i.e. the partial step) + DO ji = 1, jpi + 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/NEMO_4.0.4_surge/src/OCE/DIA/diacfl.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diacfl.F90 new file mode 100644 index 0000000..a49d851 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diacfl.F90 @@ -0,0 +1,172 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_cfl ( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z2dt, 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_cfl') + ! + ! ! setup timestep multiplier to account for initial Eulerian timestep + IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2dt = rdt + ELSE ; z2dt = rdt * 2._wp + ENDIF + ! + ! + DO jk = 1, jpk ! calculate Courant numbers + DO jj = 1, jpj + DO ji = 1, jpi + zCu_cfl(ji,jj,jk) = ABS( un(ji,jj,jk) ) * z2dt / e1u (ji,jj) ! for i-direction + zCv_cfl(ji,jj,jk) = ABS( vn(ji,jj,jk) ) * z2dt / e2v (ji,jj) ! for j-direction + zCw_cfl(ji,jj,jk) = ABS( wn(ji,jj,jk) ) * z2dt / e3w_n(ji,jj,jk) ! for k-direction + END DO + END DO + END DO + ! + ! write outputs + IF( iom_use('cfl_cu') ) CALL iom_put( 'cfl_cu', MAXVAL( zCu_cfl, dim=3 ) ) + IF( iom_use('cfl_cv') ) CALL iom_put( 'cfl_cv', MAXVAL( zCv_cfl, dim=3 ) ) + IF( iom_use('cfl_cw') ) CALL iom_put( 'cfl_cw', MAXVAL( zCw_cfl, dim=3 ) ) + + ! ! calculate maximum values and locations + IF( lk_mpp ) THEN + CALL mpp_maxloc( 'diacfl', zCu_cfl, umask, zCu_max, iloc_u ) + CALL mpp_maxloc( 'diacfl', zCv_cfl, vmask, zCv_max, iloc_v ) + CALL mpp_maxloc( 'diacfl', zCw_cfl, wmask, zCw_max, iloc_w ) + ELSE + iloc = MAXLOC( ABS( zcu_cfl(:,:,:) ) ) + iloc_u(1) = iloc(1) + nimpp - 1 + iloc_u(2) = iloc(2) + njmpp - 1 + iloc_u(3) = iloc(3) + zCu_max = zCu_cfl(iloc(1),iloc(2),iloc(3)) + ! + iloc = MAXLOC( ABS( zcv_cfl(:,:,:) ) ) + iloc_v(1) = iloc(1) + nimpp - 1 + iloc_v(2) = iloc(2) + njmpp - 1 + iloc_v(3) = iloc(3) + zCv_max = zCv_cfl(iloc(1),iloc(2),iloc(3)) + ! + iloc = MAXLOC( ABS( zcw_cfl(:,:,:) ) ) + iloc_w(1) = iloc(1) + nimpp - 1 + iloc_w(2) = iloc(2) + njmpp - 1 + iloc_w(3) = iloc(3) + zCw_max = zCw_cfl(iloc(1),iloc(2),iloc(3)) + ENDIF + ! + ! ! write out to file + IF( lwp ) THEN + 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', z2dt/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', z2dt/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', z2dt/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 = ', z2dt/rCu_max + WRITE(numout,*) ' Max Cv = ', rCv_max, ' at (i,j,k) = (',nCv_loc(1),nCv_loc(2),nCv_loc(3),') => dt/C = ', z2dt/rCv_max + WRITE(numout,*) ' Max Cw = ', rCw_max, ' at (i,j,k) = (',nCw_loc(1),nCw_loc(2),nCw_loc(3),') => dt/C = ', z2dt/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/NEMO_4.0.4_surge/src/OCE/DIA/diadct.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diadct.F90 new file mode 100644 index 0000000..ee14077 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diadct.F90 @@ -0,0 +1,1255 @@ +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) + !!---------------------------------------------------------------------- + !! does not work with agrif +#if ! defined key_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 +#if defined key_si3 + USE ice +#endif + 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) + zsigp ,&! potential density classes (99 if you don't want) + zsal ,&! salinity classes (99 if you don't want) + ztem ,&! temperature classes(99 if you don't want) + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !!--------------------------------------------------------------------- + + REWIND( numnam_ref ) ! Namelist nam_diadct in reference namelist : Diagnostic: transport through sections + READ ( numnam_ref, nam_diadct, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diadct in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist nam_diadct in configuration namelist : Diagnostic: transport through sections + 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 ) + !!--------------------------------------------------------------------- + !! *** 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 + ! + 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(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(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,nlei)*(1,nlej) + IF( iiloc >= 1 .AND. iiloc <= nlei .AND. & + ijloc >= 1 .AND. ijloc <= nlej )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=nlei ; iind=1 + ELSE IF ( cdind=='J' )THEN ; itest=nlej ; 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(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. + !! + !!------------------------------------------------------------------------------------------- + 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(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) + zsn = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) + zrhop = interp(k%I,k%J,jk,'V',rhop) + zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) + zsshn = 0.5*( sshn(k%I,k%J) + sshn(k%I,k%J+1) ) * vmask(k%I,k%J,1) + CASE(2,3) + ztn = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) + zsn = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) + zrhop = interp(k%I,k%J,jk,'U',rhop) + zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) + zsshn = 0.5*( sshn(k%I,k%J) + sshn(k%I+1,k%J) ) * umask(k%I,k%J,1) + END SELECT + ! + zdep= gdept_n(k%I,k%J,jk) + + SELECT CASE( sec%direction(jseg) ) !compute velocity with the correct direction + CASE(0,1) + zumid=0._wp + zvmid=isgnv*vn(k%I,k%J,jk)*vmask(k%I,k%J,jk) + CASE(2,3) + zumid=isgnu*un(k%I,k%J,jk)*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_n(k%I,k%J,jk) & + & + zvmid*e1v(k%I,k%J) * e3v_n(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 + +#if defined key_si3 + + !ICE CASE + !------------ + IF( sec%ll_ice_section )THEN + SELECT CASE (sec%direction(jseg)) + CASE(0) + zumid_ice = 0 + zvmid_ice = isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1)) + CASE(1) + zumid_ice = 0 + zvmid_ice = isgnv*0.5*(v_ice(k%I,k%J+1)+v_ice(k%I+1,k%J+1)) + CASE(2) + zvmid_ice = 0 + zumid_ice = isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1)) + CASE(3) + zvmid_ice = 0 + zumid_ice = isgnu*0.5*(u_ice(k%I+1,k%J)+u_ice(k%I+1,k%J+1)) + END SELECT + + zTnorm=zumid_ice*e2u(k%I,k%J)+zvmid_ice*e1v(k%I,k%J) + +#if defined key_si3 + DO jl=1,jpl + transports_2d(1,jsec,jseg) = transports_2d(1,jsec,jseg) + (zTnorm)* & + a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) * & + ( h_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) + & + h_s(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) ) + + transports_2d(2,jsec,jseg) = transports_2d(2,jsec,jseg) + (zTnorm)* & + a_i(sec%listPoint(jseg)%I,sec%listPoint(jseg)%J,jl) + END DO +#endif + + ENDIF !end of ice case +#endif + + END DO !end of loop on the segment + + ENDIF !end of sec%nb_point =0 case + ! + END SUBROUTINE transport + + + SUBROUTINE dia_dct_sum(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. + !! + !!------------------------------------------------------------- + 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(k%I,k%J,jk,'V',tsn(:,:,:,jp_tem) ) + zsn = interp(k%I,k%J,jk,'V',tsn(:,:,:,jp_sal) ) + zrhop = interp(k%I,k%J,jk,'V',rhop) + zrhoi = interp(k%I,k%J,jk,'V',rhd*rau0+rau0) + + CASE(2,3) + ztn = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_tem) ) + zsn = interp(k%I,k%J,jk,'U',tsn(:,:,:,jp_sal) ) + zrhop = interp(k%I,k%J,jk,'U',rhop) + zrhoi = interp(k%I,k%J,jk,'U',rhd*rau0+rau0) + zsshn = 0.5*( sshn(k%I,k%J) + sshn(k%I+1,k%J) ) * umask(k%I,k%J,1) + END SELECT + + zdep= gdept_n(k%I,k%J,jk) + + !------------------------------- + ! 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 + +#if defined key_si3 + + !ICE CASE + IF( sec%ll_ice_section )THEN + + IF ( transports_2d(1,jsec,jseg) .GE. 0.0 ) THEN + sec%transport( 7,1) = sec%transport( 7,1)+transports_2d(1,jsec,jseg)*1.E-6 + ELSE + sec%transport( 8,1) = sec%transport( 8,1)+transports_2d(1,jsec,jseg)*1.E-6 + ENDIF + + IF ( transports_2d(3,jsec,jseg) .GE. 0.0 ) THEN + sec%transport( 9,1) = sec%transport( 9,1)+transports_2d(2,jsec,jseg)*1.E-6 + ELSE + sec%transport(10,1) = sec%transport(10,1)+transports_2d(2,jsec,jseg)*1.E-6 + ENDIF + + ENDIF !end of ice case +#endif + + 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(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(I+1,J,K)*ptab(I,J,K) + ( e3w(I,J,K) - e3w(I+1,J,K) ) * ptab(I,J,K-1) ] + !! | | | /[ e3w(I+1,J,K) + e3w(I,J,K) - e3w(I+1,J,K) ] + !! | | | + !! | | | 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) :: ki, kj, kk ! coordinate of point + CHARACTER(len=1), INTENT(IN) :: cd_point ! type of point (U, V) + REAL(wp), 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_n(ii1,ij1,kk) + gdept_n(ii2,ij2,kk) ) * 0.5_wp + zdep1 = gdept_n(ii1,ij1,kk) - zdepu + zdep2 = gdept_n(ii2,ij2,kk) - 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_n(ii2,ij2,kk) - e3t_n(ii1,ij1,kk) + zwgt1 = ( e3w_n(ii2,ij2,kk) - e3w_n(ii1,ij1,kk) ) / e3w_n(ii2,ij2,kk) + zwgt2 = ( e3w_n(ii1,ij1,kk) - e3w_n(ii2,ij2,kk) ) / e3w_n(ii1,ij1,kk) + + 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 + +#else + !!---------------------------------------------------------------------- + !! Dummy module + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC :: ln_diadct = .FALSE. +CONTAINS + SUBROUTINE dia_dct_init + IMPLICIT NONE + END SUBROUTINE dia_dct_init + SUBROUTINE dia_dct( kt ) + IMPLICIT NONE + INTEGER, INTENT(in) :: kt + END SUBROUTINE dia_dct + ! +#endif + + !!====================================================================== +END MODULE diadct diff --git a/NEMO_4.0.4_surge/src/OCE/DIA/diaharm.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diaharm.F90 new file mode 100644 index 0000000..92275ad --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diaharm.F90 @@ -0,0 +1,467 @@ +MODULE diaharm + !!====================================================================== + !! *** MODULE diaharm *** + !! Harmonic analysis of tidal constituents + !!====================================================================== + !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE phycst + USE daymod + USE tide_mod + USE sbctide ! Tidal forcing or not + ! + USE in_out_manager ! I/O units + USE iom ! I/0 library + USE ioipsl ! NetCDF IPSL library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE timing ! preformance summary + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + INTEGER, PARAMETER :: jpincomax = 2.*jpmax_harmo + INTEGER, PARAMETER :: jpdimsparse = jpincomax*366*24*2 ! 30min for a 1yr-long run + + ! !!** namelist variables ** + LOGICAL, PUBLIC :: ln_diaharm ! Choose tidal harmonic output or not + INTEGER :: nit000_han ! First time step used for harmonic analysis + INTEGER :: nitend_han ! Last time step used for harmonic analysis + INTEGER :: nstep_han ! Time step frequency for harmonic analysis + INTEGER :: nb_ana ! Number of harmonics to analyse + + INTEGER , ALLOCATABLE, DIMENSION(:) :: name + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:,:) :: ana_temp + REAL(wp), ALLOCATABLE, DIMENSION(:) :: ana_freq, ut, vt, ft + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: out_eta, out_u, out_v + + INTEGER :: ninco, nsparse + REAL(wp) :: z1_tmp3 + INTEGER , DIMENSION(jpdimsparse) :: njsparse, nisparse + INTEGER , SAVE, DIMENSION(jpincomax) :: ipos1 + REAL(wp), DIMENSION(jpdimsparse) :: valuesparse + REAL(wp), DIMENSION(jpincomax) :: ztmp4 , ztmp7, z1_pivot + REAL(wp), SAVE, DIMENSION(jpincomax,jpincomax) :: ztmp3 , zpilier + + CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) + + PUBLIC dia_harm ! routine called by step.F90 + PUBLIC dia_harm_init ! routine called by nemogcm.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_harm_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_harm_init *** + !! + !! ** Purpose : Initialization of tidal harmonic analysis + !! + !! ** Method : Initialize frequency array and nodal factor for nit000_han + !! + !!-------------------------------------------------------------------- + INTEGER :: jh, nhan, ji + INTEGER :: ios ! Local integer output status for namelist read + + NAMELIST/nam_diaharm/ ln_diaharm, nit000_han, nitend_han, nstep_han, tname + !!---------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_harm_init: Tidal harmonic analysis initialization' + WRITE(numout,*) '~~~~~~~~~~~~~ ' + ENDIF + ! + REWIND( numnam_ref ) ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis + READ ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis + READ ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' ) + IF(lwm) WRITE ( numond, nam_diaharm ) + ! + IF(lwp) THEN + WRITE(numout,*) 'Tidal diagnostics = ', ln_diaharm + WRITE(numout,*) ' First time step used for analysis: nit000_han= ', nit000_han + WRITE(numout,*) ' Last time step used for analysis: nitend_han= ', nitend_han + WRITE(numout,*) ' Time step frequency for harmonic analysis: nstep_han = ', nstep_han + ENDIF + + IF( ln_diaharm .AND. .NOT.ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') + + IF( ln_diaharm ) THEN + + CALL tide_init_Wave + ! + ! Basic checks on harmonic analysis time window: + ! ---------------------------------------------- + IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & + & ' restart capability not implemented' ) + IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & + & 'restart capability not implemented' ) + + IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & + & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) + ! + nb_ana = 0 + DO jh=1,jpmax_harmo + DO ji=1,jpmax_harmo + IF(TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN + nb_ana=nb_ana+1 + ENDIF + END DO + END DO + ! + IF(lwp) THEN + WRITE(numout,*) ' Namelist nam_diaharm' + WRITE(numout,*) ' nb_ana = ', nb_ana + CALL flush(numout) + ENDIF + ! + IF (nb_ana > jpmax_harmo) THEN + WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' + WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo + CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) + ENDIF + + ALLOCATE(name(nb_ana)) + DO jh=1,nb_ana + DO ji=1,jpmax_harmo + IF (TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN + name(jh) = ji + EXIT + END IF + END DO + END DO + + ! Initialize frequency array: + ! --------------------------- + ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) + + CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) + + IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' + + DO jh = 1, nb_ana + IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh) + END DO + + ! Initialize temporary arrays: + ! ---------------------------- + ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) + ana_temp(:,:,:,:) = 0._wp + + ENDIF + + END SUBROUTINE dia_harm_init + + + SUBROUTINE dia_harm( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_harm *** + !! + !! ** Purpose : Tidal harmonic analysis main routine + !! + !! ** Action : Sums ssh/u/v over time analysis [nit000_han,nitend_han] + !! + !!-------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt + ! + INTEGER :: ji, jj, jh, jc, nhc + REAL(wp) :: ztime, ztemp + !!-------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_harm') + ! + IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN + ! + ztime = (kt-nit000+1) * rdt + ! + nhc = 0 + DO jh = 1, nb_ana + DO jc = 1, 2 + nhc = nhc+1 + ztemp = ( MOD(jc,2) * ft(jh) *COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & + & +(1.-MOD(jc,2))* ft(jh) *SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh))) + ! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ana_temp(ji,jj,nhc,1) = ana_temp(ji,jj,nhc,1) + ztemp * sshn(ji,jj) * ssmask (ji,jj) ! elevation + ana_temp(ji,jj,nhc,2) = ana_temp(ji,jj,nhc,2) + ztemp * un_b(ji,jj) * ssumask(ji,jj) ! u-vel + ana_temp(ji,jj,nhc,3) = ana_temp(ji,jj,nhc,3) + ztemp * vn_b(ji,jj) * ssvmask(ji,jj) ! v-vel + END DO + END DO + END DO + END DO + END IF + ! + IF( kt == nitend_han ) CALL dia_harm_end + ! + IF( ln_timing ) CALL timing_stop('dia_harm') + ! + END SUBROUTINE dia_harm + + + SUBROUTINE dia_harm_end + !!---------------------------------------------------------------------- + !! *** ROUTINE diaharm_end *** + !! + !! ** Purpose : Compute the Real and Imaginary part of tidal constituents + !! + !! ** Action : Decompose the signal on the harmonic constituents + !! + !!-------------------------------------------------------------------- + INTEGER :: ji, jj, jh, jc, jn, nhan + INTEGER :: ksp, kun, keq + REAL(wp) :: ztime, ztime_ini, ztime_end, z1_han + !!-------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dia_harm_end: kt=nitend_han: Perform harmonic analysis' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + ALLOCATE( out_eta(jpi,jpj,2*nb_ana), out_u(jpi,jpj,2*nb_ana), out_v(jpi,jpj,2*nb_ana) ) + + ztime_ini = nit000_han*rdt ! Initial time in seconds at the beginning of analysis + ztime_end = nitend_han*rdt ! Final time in seconds at the end of analysis + nhan = (nitend_han-nit000_han+1)/nstep_han ! Number of dumps used for analysis + z1_han = 1._wp / REAL(nhan-1) + + ninco = 2*nb_ana + + ksp = 0 + keq = 0 + DO jn = 1, nhan + ztime=( (nhan-jn)*ztime_ini + (jn-1)*ztime_end ) * z1_han + keq = keq + 1 + kun = 0 + DO jh = 1, nb_ana + DO jc = 1, 2 + kun = kun + 1 + ksp = ksp + 1 + nisparse(ksp) = keq + njsparse(ksp) = kun + valuesparse(ksp) = ( MOD(jc,2) * ft(jh) * COS(ana_freq(jh)*ztime + vt(jh) + ut(jh)) & + & + (1.-MOD(jc,2))* ft(jh) * SIN(ana_freq(jh)*ztime + vt(jh) + ut(jh)) ) + END DO + END DO + END DO + + nsparse = ksp + + IF( nsparse > jpdimsparse ) CALL ctl_stop( 'STOP', 'SUR_DETERMINE : nsparse .GT. jpdimsparse') + IF( ninco > jpincomax ) CALL ctl_stop( 'STOP', 'SUR_DETERMINE : ninco .GT. jpincomax') + + CALL SUR_DETERMINE_INIT + + ! Elevation: + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + + ! Fill input array + ztmp4(1:nb_ana*2) = ana_temp(ji,jj,1:nb_ana*2,1) + CALL SUR_DETERMINE + + ! Fill output array + DO jh = 1, nb_ana + out_eta(ji,jj,jh ) = ztmp7((jh-1)*2+1) * ssmask(ji,jj) + out_eta(ji,jj,jh+nb_ana) = -ztmp7((jh-1)*2+2) * ssmask(ji,jj) + END DO + END DO + END DO + + ! ubar: + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + + ! Fill input array + ztmp4(1:nb_ana*2) = ana_temp(ji,jj,1:nb_ana*2,2) + CALL SUR_DETERMINE + + ! Fill output array + DO jh = 1, nb_ana + out_u(ji,jj, jh) = ztmp7((jh-1)*2+1) * ssumask(ji,jj) + out_u(ji,jj,nb_ana+jh) = -ztmp7((jh-1)*2+2) * ssumask(ji,jj) + END DO + + END DO + END DO + + ! vbar: + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + + ! Fill input array + ztmp4(1:nb_ana*2) = ana_temp(ji,jj,1:nb_ana*2,3) + CALL SUR_DETERMINE + + ! Fill output array + DO jh = 1, nb_ana + out_v(ji,jj, jh) = ztmp7((jh-1)*2+1) * ssvmask(ji,jj) + out_v(ji,jj,nb_ana+jh) = -ztmp7((jh-1)*2+2) * ssvmask(ji,jj) + END DO + + END DO + END DO + ! + ! clem: we could avoid this call if all the loops were from 1:jpi and 1:jpj + ! but I think this is the most efficient + CALL lbc_lnk_multi( 'dia_harm_end', out_eta, 'T', 1., out_u, 'U', -1. , out_v, 'V', -1. ) + ! + CALL dia_wri_harm ! Write results in files + ! + DEALLOCATE( out_eta, out_u, out_v ) + ! + END SUBROUTINE dia_harm_end + + + SUBROUTINE dia_wri_harm + !!-------------------------------------------------------------------- + !! *** ROUTINE dia_wri_harm *** + !! + !! ** Purpose : Write tidal harmonic analysis results in a netcdf file + !!-------------------------------------------------------------------- + INTEGER :: jh + !!---------------------------------------------------------------------- + + IF(lwp) WRITE(numout,*) ' ' + IF(lwp) WRITE(numout,*) 'dia_wri_harm : Write harmonic analysis results' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + + ! A) Elevation + !///////////// + DO jh = 1, nb_ana + CALL iom_put( TRIM(tname(jh))//'x', out_eta(:,:,jh) ) + CALL iom_put( TRIM(tname(jh))//'y', out_eta(:,:,jh+nb_ana) ) + END DO + + ! B) ubar + !///////// + DO jh = 1, nb_ana + CALL iom_put( TRIM(tname(jh))//'x_u', out_u(:,:,jh) ) + CALL iom_put( TRIM(tname(jh))//'y_u', out_u(:,:,jh+nb_ana) ) + END DO + + ! C) vbar + !///////// + DO jh = 1, nb_ana + CALL iom_put( TRIM(tname(jh))//'x_v', out_v(:,:,jh ) ) + CALL iom_put( TRIM(tname(jh))//'y_v', out_v(:,:,jh+nb_ana) ) + END DO + ! + END SUBROUTINE dia_wri_harm + + + SUBROUTINE SUR_DETERMINE_INIT + !!--------------------------------------------------------------------------------- + !! *** ROUTINE SUR_DETERMINE_INIT *** + !! + !!--------------------------------------------------------------------------------- + INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jh1_sd, jh2_sd + INTEGER :: ipivot + REAL(wp) :: zval1, zval2, zcol1, zcol2 + INTEGER , DIMENSION(jpincomax) :: ipos2 + !!--------------------------------------------------------------------------------- + ! + ! + ztmp3(:,:) = 0._wp + ! + DO jh1_sd = 1, nsparse + DO jh2_sd = 1, nsparse + IF( nisparse(jh2_sd) == nisparse(jh1_sd) ) THEN + ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) & + & + valuesparse(jh1_sd)*valuesparse(jh2_sd) + ENDIF + END DO + END DO + ! + DO jj_sd = 1, ninco + ipos1(jj_sd) = jj_sd + ipos2(jj_sd) = jj_sd + END DO + ! + DO ji_sd = 1, ninco + ! + !find greatest non-zero pivot: + zval1 = ABS(ztmp3(ji_sd,ji_sd)) + ! + ipivot = ji_sd + DO jj_sd = ji_sd, ninco + zval2 = ABS(ztmp3(ji_sd,jj_sd)) + IF( zval2 >= zval1 )THEN + ipivot = jj_sd + zval1 = zval2 + ENDIF + END DO + ! + DO ji1_sd = 1, ninco + zcol1 = ztmp3(ji1_sd,ji_sd) + zcol2 = ztmp3(ji1_sd,ipivot) + ztmp3(ji1_sd,ji_sd) = zcol2 + ztmp3(ji1_sd,ipivot) = zcol1 + END DO + ! + ipos2(ji_sd) = ipos1(ipivot) + ipos2(ipivot) = ipos1(ji_sd) + ipos1(ji_sd) = ipos2(ji_sd) + ipos1(ipivot) = ipos2(ipivot) + z1_pivot(ji_sd) = 1._wp / ztmp3(ji_sd,ji_sd) + DO jj_sd = 1, ninco + ztmp3(ji_sd,jj_sd) = ztmp3(ji_sd,jj_sd) * z1_pivot(ji_sd) + END DO + ! + DO ji2_sd = ji_sd+1, ninco + zpilier(ji2_sd,ji_sd) = ztmp3(ji2_sd,ji_sd) + DO jj_sd=1,ninco + ztmp3(ji2_sd,jj_sd) = ztmp3(ji2_sd,jj_sd) - ztmp3(ji_sd,jj_sd) * zpilier(ji2_sd,ji_sd) + END DO + END DO + ! + END DO + ! + z1_tmp3 = 1._wp / ztmp3(ninco,ninco) + ! + END SUBROUTINE SUR_DETERMINE_INIT + + + SUBROUTINE SUR_DETERMINE + !!--------------------------------------------------------------------------------- + !! *** ROUTINE SUR_DETERMINE *** + !! + !!--------------------------------------------------------------------------------- + INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd + REAL(wp) :: zx1 + REAL(wp), DIMENSION(jpincomax) :: ztmpx + !!--------------------------------------------------------------------------------- + ! + DO ji_sd = 1, ninco + ztmp4(ji_sd) = ztmp4(ji_sd) * z1_pivot(ji_sd) + DO ji2_sd = ji_sd+1, ninco + ztmp4(ji2_sd) = ztmp4(ji2_sd) - ztmp4(ji_sd) * zpilier(ji2_sd,ji_sd) + END DO + END DO + + !system solving: + ztmpx(ninco) = ztmp4(ninco) * z1_tmp3 + DO ji_sd = ninco-1, 1, -1 + zx1 = 0._wp + DO jj_sd = ji_sd+1, ninco + zx1 = zx1 + ztmpx(jj_sd) * ztmp3(ji_sd,jj_sd) + END DO + ztmpx(ji_sd) = ztmp4(ji_sd) - zx1 + END DO + + DO jj_sd = 1, ninco + ztmp7(ipos1(jj_sd)) = ztmpx(jj_sd) + END DO + ! + END SUBROUTINE SUR_DETERMINE + + + !!====================================================================== +END MODULE diaharm diff --git a/NEMO_4.0.4_surge/src/OCE/DIA/diahsb.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diahsb.F90 new file mode 100644 index 0000000..752f4d9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diahsb.F90 @@ -0,0 +1,424 @@ +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 sbcrnf ! river runoff + USE sbcisf ! ice shelves + 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_t, frc_s, frc_v ! global forcing trends + REAL(wp) :: frc_wn_t, frc_wn_s ! global forcing trends + ! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: surf + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: surf_ini , ssh_ini ! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ssh_hc_loc_ini, ssh_sc_loc_ini ! + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: hc_loc_ini, sc_loc_ini, e3t_ini ! + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_hsb( kt ) + !!--------------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk ! dummy loop indice + REAL(wp) :: zdiff_hc , zdiff_sc ! heat and salt content variations + REAL(wp) :: zdiff_hc1 , zdiff_sc1 ! - - - - + REAL(wp) :: 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(wp) :: z_frc_trd_v ! - - + REAL(wp) :: z_wn_trd_t , z_wn_trd_s ! - - + REAL(wp) :: z_ssh_hc , z_ssh_sc ! - - + REAL(wp), DIMENSION(jpi,jpj) :: z2d0, z2d1 ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpkm1) :: zwrk ! 3D workspace + !!--------------------------------------------------------------------------- + IF( ln_timing ) CALL timing_start('dia_hsb') + ! + tsn(:,:,:,1) = tsn(:,:,:,1) * tmask(:,:,:) ; tsb(:,:,:,1) = tsb(:,:,:,1) * tmask(:,:,:) ; + tsn(:,:,:,2) = tsn(:,:,:,2) * tmask(:,:,:) ; tsb(:,:,:,2) = tsb(:,:,:,2) * tmask(:,:,:) ; + ! ------------------------- ! + ! 1 - Trends due to forcing ! + ! ------------------------- ! + z_frc_trd_v = r1_rau0 * glob_sum( 'diahsb', - ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) * surf(:,:) ) ! volume fluxes + z_frc_trd_t = glob_sum( 'diahsb', sbc_tsc(:,:,jp_tem) * surf(:,:) ) ! heat fluxes + z_frc_trd_s = glob_sum( 'diahsb', sbc_tsc(:,:,jp_sal) * surf(:,:) ) ! salt fluxes + ! ! Add runoff heat & salt input + IF( ln_rnf ) z_frc_trd_t = z_frc_trd_t + glob_sum( 'diahsb', rnf_tsc(:,:,jp_tem) * surf(:,:) ) + IF( ln_rnf_sal) z_frc_trd_s = z_frc_trd_s + glob_sum( 'diahsb', rnf_tsc(:,:,jp_sal) * surf(:,:) ) + ! ! Add ice shelf heat & salt input + IF( ln_isf ) z_frc_trd_t = z_frc_trd_t + glob_sum( 'diahsb', risf_tsc(:,:,jp_tem) * surf(:,:) ) + ! ! Add penetrative solar radiation + IF( ln_traqsr ) z_frc_trd_t = z_frc_trd_t + r1_rau0_rcp * glob_sum( 'diahsb', qsr (:,:) * surf(:,:) ) + ! ! Add geothermal heat flux + IF( ln_trabbc ) z_frc_trd_t = z_frc_trd_t + glob_sum( 'diahsb', qgh_trd0(:,:) * surf(:,:) ) + ! + IF( ln_linssh ) THEN + IF( ln_isfcav ) THEN + DO ji=1,jpi + DO jj=1,jpj + z2d0(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_tem) + z2d1(ji,jj) = surf(ji,jj) * wn(ji,jj,mikt(ji,jj)) * tsb(ji,jj,mikt(ji,jj),jp_sal) + END DO + END DO + ELSE + z2d0(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_tem) + z2d1(:,:) = surf(:,:) * wn(:,:,1) * tsb(:,:,1,jp_sal) + END IF + z_wn_trd_t = - glob_sum( 'diahsb', z2d0 ) + z_wn_trd_s = - glob_sum( 'diahsb', z2d1 ) + ENDIF + + frc_v = frc_v + z_frc_trd_v * rdt + frc_t = frc_t + z_frc_trd_t * rdt + frc_s = frc_s + z_frc_trd_s * rdt + ! ! Advection flux through fixed surface (z=0) + IF( ln_linssh ) THEN + frc_wn_t = frc_wn_t + z_wn_trd_t * rdt + frc_wn_s = frc_wn_s + z_wn_trd_s * rdt + ENDIF + + ! ------------------------ ! + ! 2 - Content variations ! + ! ------------------------ ! + ! glob_sum_full is needed because you keep the full interior domain to compute the sum (iscpl) + + ! ! volume variation (calculated with ssh) + zdiff_v1 = glob_sum_full( 'diahsb', surf(:,:)*sshn(:,:) - 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 + z2d0(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) - ssh_hc_loc_ini(ji,jj) ) + z2d1(ji,jj) = surf(ji,jj) * ( tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) - ssh_sc_loc_ini(ji,jj) ) + END DO + END DO + ELSE ! no under ice-shelf seas + z2d0(:,:) = surf(:,:) * ( tsn(:,:,1,jp_tem) * sshn(:,:) - ssh_hc_loc_ini(:,:) ) + z2d1(:,:) = surf(:,:) * ( tsn(:,:,1,jp_sal) * sshn(:,:) - ssh_sc_loc_ini(:,:) ) + END IF + z_ssh_hc = glob_sum_full( 'diahsb', z2d0 ) + z_ssh_sc = glob_sum_full( 'diahsb', z2d1 ) + ENDIF + ! + DO jk = 1, jpkm1 ! volume variation (calculated with scale factors) + zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk) - surf_ini(:,:)*e3t_ini(:,:,jk) ) * tmask(:,:,jk) + END DO + zdiff_v2 = glob_sum_full( 'diahsb', zwrk(:,:,:) ) + DO jk = 1, jpkm1 ! heat content variation + zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk)*tsn(:,:,jk,jp_tem) - surf_ini(:,:)*hc_loc_ini(:,:,jk) ) * tmask(:,:,jk) + END DO + zdiff_hc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) + DO jk = 1, jpkm1 ! salt content variation + zwrk(:,:,jk) = ( surf(:,:)*e3t_n(:,:,jk)*tsn(:,:,jk,jp_sal) - surf_ini(:,:)*sc_loc_ini(:,:,jk) ) * tmask(:,:,jk) + END DO + zdiff_sc = glob_sum_full( 'diahsb', zwrk(:,:,:) ) + + ! ------------------------ ! + ! 3 - 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 + + ! ----------------------- ! + ! 4 - Diagnostics writing ! + ! ----------------------- ! + DO jk = 1, jpkm1 ! total ocean volume (calculated with scale factors) + zwrk(:,:,jk) = surf(:,:) * e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + zvol_tot = glob_sum_full( 'diahsb', zwrk(:,:,:) ) + +!!gm to be added ? +! IF( ln_linssh ) THEN ! fixed volume, add the ssh contribution +! zvol_tot = zvol_tot + glob_sum( 'diahsb', surf(:,:) * sshn(:,:) ) +! ENDIF +!!gm end + + CALL iom_put( 'bgfrcvol' , frc_v * 1.e-9 ) ! vol - surface forcing (km3) + CALL iom_put( 'bgfrctem' , frc_t * rau0 * rcp * 1.e-20 ) ! hc - surface forcing (1.e20 J) + CALL iom_put( 'bgfrchfx' , frc_t * rau0 * rcp / & ! hc - surface forcing (W/m2) + & ( surf_tot * kt * rdt ) ) + 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 * rau0 * rcp ) ! Heat content drift (1.e20 J) + CALL iom_put( 'bgheatfx' , zdiff_hc * rau0 * rcp / & ! Heat flux drift (W/m2) + & ( surf_tot * kt * rdt ) ) + 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 * rau0 * rcp ) ! Heat content drift (1.e20 J) + CALL iom_put( 'bgheatfx' , zdiff_hc1 * rau0 * rcp / & ! Heat flux drift (W/m2) + & ( surf_tot * kt * rdt ) ) + 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, 'WRITE' ) + ! + IF( ln_timing ) CALL timing_stop('dia_hsb') + ! + END SUBROUTINE dia_hsb + + + SUBROUTINE dia_hsb_rst( kt, 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 + 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, ldxios = lrxios ) + CALL iom_get( numror, 'frc_t', frc_t, ldxios = lrxios ) + CALL iom_get( numror, 'frc_s', frc_s, ldxios = lrxios ) + IF( ln_linssh ) THEN + CALL iom_get( numror, 'frc_wn_t', frc_wn_t, ldxios = lrxios ) + CALL iom_get( numror, 'frc_wn_s', frc_wn_s, ldxios = lrxios ) + ENDIF + CALL iom_get( numror, jpdom_autoglo, 'surf_ini' , surf_ini , ldxios = lrxios ) ! ice sheet coupling + CALL iom_get( numror, jpdom_autoglo, 'ssh_ini' , ssh_ini , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'e3t_ini' , e3t_ini , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'hc_loc_ini', hc_loc_ini, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'sc_loc_ini', sc_loc_ini, ldxios = lrxios ) + IF( ln_linssh ) THEN + CALL iom_get( numror, jpdom_autoglo, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lrxios ) + 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(:,:) = sshn(:,:) ! 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_n(:,:,jk) * tmask(:,:,jk) ! initial vertical scale factors + hc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_tem) * e3t_n(:,:,jk) * tmask(:,:,jk) ! initial heat content + sc_loc_ini(:,:,jk) = tsn(:,:,jk,jp_sal) * e3t_n(:,:,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) = tsn(ji,jj,mikt(ji,jj),jp_tem) * sshn(ji,jj) ! initial heat content in ssh + ssh_sc_loc_ini(ji,jj) = tsn(ji,jj,mikt(ji,jj),jp_sal) * sshn(ji,jj) ! initial salt content in ssh + END DO + END DO + ELSE + ssh_hc_loc_ini(:,:) = tsn(:,:,1,jp_tem) * sshn(:,:) ! initial heat content in ssh + ssh_sc_loc_ini(:,:) = tsn(:,:,1,jp_sal) * sshn(:,:) ! 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,*) + ! + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_v', frc_v, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_t', frc_t, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_s', frc_s, ldxios = lwxios ) + IF( ln_linssh ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_t', frc_wn_t, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'frc_wn_s', frc_wn_s, ldxios = lwxios ) + ENDIF + CALL iom_rstput( kt, nitrst, numrow, 'surf_ini' , surf_ini , ldxios = lwxios ) ! ice sheet coupling + CALL iom_rstput( kt, nitrst, numrow, 'ssh_ini' , ssh_ini , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_ini' , e3t_ini , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'hc_loc_ini', hc_loc_ini, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sc_loc_ini', sc_loc_ini, ldxios = lwxios ) + IF( ln_linssh ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'ssh_hc_loc_ini', ssh_hc_loc_ini, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_sc_loc_ini', ssh_sc_loc_ini, ldxios = lwxios ) + ENDIF + IF( lwxios ) CALL iom_swap( cxios_context ) + ! + ENDIF + ! + END SUBROUTINE dia_hsb_rst + + + SUBROUTINE dia_hsb_init + !!--------------------------------------------------------------------------- + !! *** 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 :: 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 + REWIND( numnam_ref ) ! Namelist namhsb in reference namelist + READ ( numnam_ref, namhsb, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namhsb in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namhsb in configuration 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 + + IF(lwxios) THEN +! define variables in restart file when writing with XIOS + CALL iom_set_rstw_var_active('frc_v') + CALL iom_set_rstw_var_active('frc_t') + CALL iom_set_rstw_var_active('frc_s') + CALL iom_set_rstw_var_active('surf_ini') + CALL iom_set_rstw_var_active('ssh_ini') + CALL iom_set_rstw_var_active('e3t_ini') + CALL iom_set_rstw_var_active('hc_loc_ini') + CALL iom_set_rstw_var_active('sc_loc_ini') + IF( ln_linssh ) THEN + CALL iom_set_rstw_var_active('ssh_hc_loc_ini') + CALL iom_set_rstw_var_active('ssh_sc_loc_ini') + CALL iom_set_rstw_var_active('frc_wn_t') + CALL iom_set_rstw_var_active('frc_wn_s') + ENDIF + ENDIF + ! ------------------- ! + ! 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), 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, 'READ' ) !* read or initialize all required files + ! + END SUBROUTINE dia_hsb_init + + !!====================================================================== +END MODULE diahsb diff --git a/NEMO_4.0.4_surge/src/OCE/DIA/diahth.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diahth.F90 new file mode 100644 index 0000000..1648a65 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diahth.F90 @@ -0,0 +1,392 @@ +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] + + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!--------------------------------------------------------------------- + !! *** 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 :: 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 = 1, jpj + DO ji = 1, jpi + zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) + 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 = 1, jpj + DO ji = 1, jpi + zztmp = gdepw_n(ji,jj,mbkt(ji,jj)+1) + 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 = 1, jpj + DO ji = 1, jpi + IF( tmask(ji,jj,nla10) == 1. ) THEN + zu = 1779.50 + 11.250 * tsn(ji,jj,nla10,jp_tem) - 3.80 * tsn(ji,jj,nla10,jp_sal) & + & - 0.0745 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem) & + & - 0.0100 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_sal) + zv = 5891.00 + 38.000 * tsn(ji,jj,nla10,jp_tem) + 3.00 * tsn(ji,jj,nla10,jp_sal) & + & - 0.3750 * tsn(ji,jj,nla10,jp_tem) * tsn(ji,jj,nla10,jp_tem) + zut = 11.25 - 0.149 * tsn(ji,jj,nla10,jp_tem) - 0.01 * tsn(ji,jj,nla10,jp_sal) + zvt = 38.00 - 0.750 * tsn(ji,jj,nla10,jp_tem) + 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 ! loop from bottom to 2 + DO jj = 1, jpj + DO ji = 1, jpi + ! + zzdep = gdepw_n(ji,jj,jk) + zztmp = ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) & + & / 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 ! loop from bottom to nlb10 + DO jj = 1, jpj + DO ji = 1, jpi + ! + zzdep = gdepw_n(ji,jj,jk) * tmask(ji,jj,1) + ! + zztmp = tsn(ji,jj,nla10,jp_tem) - tsn(ji,jj,jk,jp_tem) ! - 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( ztem2, hd20 ) + CALL iom_put( '20d', hd20 ) + ENDIF + ! + IF( iom_use ('26d') ) THEN ! depth of the 26 isotherm + ztem2 = 26. + CALL dia_hth_dep( ztem2, hd26 ) + CALL iom_put( '26d', hd26 ) + ENDIF + ! + IF( iom_use ('28d') ) THEN ! depth of the 28 isotherm + ztem2 = 28. + CALL dia_hth_dep( 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( zzdep, tsn(:,:,:,jp_tem), htc3 ) + CALL iom_put( 'hc300', rau0_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( zzdep, tsn(:,:,:,jp_tem), htc7 ) + CALL iom_put( 'hc700', rau0_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( zzdep, tsn(:,:,:,jp_tem), htc20 ) + CALL iom_put( 'hc2000', rau0_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( ptem, pdept ) + ! + 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 ! beware temperature is not always decreasing with depth => loop from top to bottom + DO jj = 1, jpj + DO ji = 1, jpi + zztmp = tsn(ji,jj,jk,jp_tem) + IF( zztmp >= ptem ) iktem(ji,jj) = jk + END DO + END DO + END DO + + ! ------------------------------- ! + ! Depth of ptem isotherm ! + ! ------------------------------- ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zzdep = gdepw_n(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean bottom + ! + iid = iktem(ji,jj) + IF( iid /= 1 ) THEN + zztmp = gdept_n(ji,jj,iid ) & ! linear interpolation + & + ( gdept_n(ji,jj,iid+1) - gdept_n(ji,jj,iid) ) & + & * ( 20.*tmask(ji,jj,iid+1) - tsn(ji,jj,iid,jp_tem) ) & + & / ( tsn(ji,jj,iid+1,jp_tem) - tsn(ji,jj,iid,jp_tem) + (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( pdep, ptn, phtc ) + ! + REAL(wp), INTENT(in) :: pdep ! depth over the heat content + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptn + 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(:,:) = sshn(:,:) ; phtc(:,:) = ptn(:,:,1) * sshn(:,:) * tmask(:,:,1) + ENDIF + ! + ilevel(:,:) = 1 + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( ( gdept_n(ji,jj,jk) < pdep ) .AND. ( tmask(ji,jj,jk) == 1 ) ) THEN + ilevel(ji,jj) = jk + zthick(ji,jj) = zthick(ji,jj) + e3t_n(ji,jj,jk) + phtc (ji,jj) = phtc (ji,jj) + e3t_n(ji,jj,jk) * ptn(ji,jj,jk) + ENDIF + ENDDO + ENDDO + ENDDO + ! + DO jj = 1, jpj + DO ji = 1, jpi + ik = ilevel(ji,jj) + zthick(ji,jj) = pdep - zthick(ji,jj) ! remaining thickness to reach depht pdep + phtc(ji,jj) = phtc(ji,jj) + ptn(ji,jj,ik+1) * MIN( e3t_n(ji,jj,ik+1), zthick(ji,jj) ) & + * tmask(ji,jj,ik+1) + END DO + ENDDO + ! + ! + END SUBROUTINE dia_hth_htc + + !!====================================================================== +END MODULE diahth diff --git a/NEMO_4.0.4_surge/src/OCE/DIA/dianam.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/dianam.F90 new file mode 100644 index 0000000..8889e0c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/dianam.F90 @@ -0,0 +1,136 @@ +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$ + !! 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=<cexper>_<clave>_<idtbeg>_<idtend>_<cdsuff> + !! <clave> = averaging frequency (DA, MO, etc...) + !! <idtbeg>,<idtend> 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(wp) :: zsec1, zsec2 ! not used + REAL(wp) :: 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( rdt ) ! 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 = rdt / rday * REAL( nitend - nit000, wp ) ! length of the run in days + zjul = fjulday - rdt / 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/NEMO_4.0.4_surge/src/OCE/DIA/diaprod.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diaprod.F90 new file mode 100644 index 0000000..eeb83a6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diaprod.F90 @@ -0,0 +1,270 @@ +MODULE diaprod +! Requires key_iom_put +# if defined key_iomput + !!====================================================================== + !! *** MODULE diaprod *** + !! Ocean diagnostics : write ocean product diagnostics + !!===================================================================== + !! History : 3.4 ! 2012 (D. Storkey) Original code + !! 4.0 ! 2019 (D. Storkey) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dia_prod : calculate and write out product diagnostics + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE domvvl ! for thickness weighted diagnostics if key_vvl + USE eosbn2 ! equation of state (eos call) + USE phycst ! physical constants + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE in_out_manager ! I/O manager + USE iom + USE ioipsl + USE lib_mpp ! MPP library + USE timing ! preformance summary + + IMPLICIT NONE + PRIVATE + + PUBLIC dia_prod ! routines called by step.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OPA 3.4 , NEMO Consortium (2012) + !! $Id$ + !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_prod( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_prod *** + !! + !! ** Purpose : Write out product diagnostics (uT, vS etc.) + !! + !! ** Method : use iom_put + !! Product diagnostics are not thickness-weighted in this routine. + !! They should be thickness-weighted using XIOS if key_vvl is set. + !!---------------------------------------------------------------------- + !! + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zztmp, zztmpx, zztmpy ! + !! + REAL(wp), POINTER, DIMENSION(:,:) :: z2d ! 2D workspace + REAL(wp), POINTER, DIMENSION(:,:,:) :: z3d ! 3D workspace + REAL(wp), POINTER, DIMENSION(:,:,:) :: zrhop ! potential density + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_prod') + ! + ALLOCATE( z2d(jpi,jpj), z3d(jpi,jpj,jpk), zrhop(jpi,jpj,jpk) ) + ! + + IF( iom_use("urhop") .OR. iom_use("vrhop") .OR. iom_use("wrhop") & +#if ! defined key_diaar5 + & .OR. iom_use("rhop") & +#endif + & ) THEN + CALL eos( tsn, z3d, zrhop ) ! now in situ and potential density + zrhop(:,:,:) = zrhop(:,:,:)-1000.e0 ! reference potential density to 1000 to avoid precision issues in rhop2 calculation + zrhop(:,:,jpk) = 0._wp +#if ! defined key_diaar5 + CALL iom_put( 'rhop', zrhop ) +#else + ! If key_diaar5 set then there is already an iom_put call to output rhop. + ! Really should be a standard diagnostics option? +#endif + ENDIF + + IF( iom_use("ut") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) + END DO + END DO + END DO + CALL iom_put( "ut", z3d ) ! product of temperature and zonal velocity at U points + ENDIF + + IF( iom_use("vt") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) + END DO + END DO + END DO + CALL iom_put( "vt", z3d ) ! product of temperature and meridional velocity at V points + ENDIF + + IF( iom_use("wt") ) THEN + z3d(:,:,:) = 0.e0 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,1) = wn(ji,jj,1) * tsn(ji,jj,1,jp_tem) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = wn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk-1,jp_tem) + tsn(ji,jj,jk,jp_tem) ) + END DO + END DO + END DO + CALL iom_put( "wt", z3d ) ! product of temperature and vertical velocity at W points + ENDIF + + IF( iom_use("us") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) + END DO + END DO + END DO + CALL iom_put( "us", z3d ) ! product of salinity and zonal velocity at U points + ENDIF + + IF( iom_use("vs") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) + END DO + END DO + END DO + CALL iom_put( "vs", z3d ) ! product of salinity and meridional velocity at V points + ENDIF + + IF( iom_use("ws") ) THEN + z3d(:,:,:) = 0.e0 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,1) = wn(ji,jj,1) * tsn(ji,jj,1,jp_sal) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = wn(ji,jj,jk) * 0.5 * ( tsn(ji,jj,jk-1,jp_sal) + tsn(ji,jj,jk,jp_sal) ) + END DO + END DO + END DO + CALL iom_put( "ws", z3d ) ! product of salinity and vertical velocity at W points + ENDIF + + IF( iom_use("uv") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = 0.25 * ( un(ji-1,jj,jk) + un(ji,jj,jk) ) * ( vn(ji,jj-1,jk) + vn(ji,jj,jk) ) + END DO + END DO + END DO + CALL iom_put( "uv", z3d ) ! product of zonal velocity and meridional velocity at T points + ENDIF + + IF( iom_use("uw") ) THEN + z3d(:,:,:) = 0.e0 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,1) = 0.5 * ( wn(ji,jj,1) + wn(ji+1,jj,1) ) * un(ji,jj,1) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = 0.25 * ( wn(ji,jj,jk) + wn(ji+1,jj,jk) ) * ( un(ji,jj,jk-1) + un(ji,jj,jk) ) + END DO + END DO + END DO + CALL iom_put( "uw", z3d ) ! product of zonal velocity and vertical velocity at UW points + ENDIF + + IF( iom_use("vw") ) THEN + z3d(:,:,:) = 0.e0 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,1) = 0.5 * ( wn(ji,jj,1) + wn(ji,jj+1,1) ) * vn(ji,jj,1) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = 0.25 * ( wn(ji,jj,jk) + wn(ji,jj+1,jk) ) * ( vn(ji,jj,jk-1) + vn(ji,jj,jk) ) + END DO + END DO + END DO + CALL iom_put( "vw", z3d ) ! product of meriodional velocity and vertical velocity at VW points + ENDIF + + IF( iom_use("urhop") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = un(ji,jj,jk) * 0.5 * ( zrhop(ji,jj,jk) + zrhop(ji+1,jj,jk) ) + END DO + END DO + END DO + CALL iom_put( "urhop", z3d ) ! product of density and zonal velocity at U points + ENDIF + + IF( iom_use("vrhop") ) THEN + z3d(:,:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = vn(ji,jj,jk) * 0.5 * ( zrhop(ji,jj,jk) + zrhop(ji,jj+1,jk) ) + END DO + END DO + END DO + CALL iom_put( "vrhop", z3d ) ! product of density and meridional velocity at V points + ENDIF + + IF( iom_use("wrhop") ) THEN + z3d(:,:,:) = 0.e0 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,1) = wn(ji,jj,1) * zrhop(ji,jj,1) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z3d(ji,jj,jk) = wn(ji,jj,jk) * 0.5 * ( zrhop(ji,jj,jk-1) + zrhop(ji,jj,jk) ) + END DO + END DO + END DO + CALL iom_put( "wrhop", z3d ) ! product of density and vertical velocity at W points + ENDIF + + ! + DEALLOCATE( z2d, z3d, zrhop ) + ! + IF( ln_timing ) CALL timing_stop('dia_prod') + ! + END SUBROUTINE dia_prod +#else + !!---------------------------------------------------------------------- + !! Default option : NO diaprod + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_diaprod = .FALSE. ! coupled flag +CONTAINS + SUBROUTINE dia_prod( kt ) ! Empty routine + INTEGER :: kt + WRITE(*,*) 'dia_prod: You should not have seen this print! error?', kt + END SUBROUTINE dia_prod +#endif + !!====================================================================== +END MODULE diaprod diff --git a/NEMO_4.0.4_surge/src/OCE/DIA/diaptr.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diaptr.F90 new file mode 100644 index 0000000..6c65ae8 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diaptr.F90 @@ -0,0 +1,640 @@ +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 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_sj + MODULE PROCEDURE ptr_sj_3d, ptr_sj_2d + END INTERFACE + + PUBLIC ptr_sj ! call by tra_ldf & tra_adv routines + PUBLIC ptr_sjk ! + PUBLIC dia_ptr_init ! call in memogcm + PUBLIC dia_ptr ! call in step module + PUBLIC dia_ptr_hst ! called from tra_ldf/tra_adv routines + + ! !!** namelist namptr ** + 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) + + LOGICAL, PUBLIC :: ln_diaptr ! Poleward transport flag (T) or not (F) + LOGICAL, PUBLIC :: ln_subbas ! Atlantic/Pacific/Indian basins calculation + INTEGER, PARAMETER, PUBLIC :: nptr = 5 ! (glo, atl, pac, ind, ipc) + + 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 rau0 x Cp) + REAL(wp) :: rc_ggram = 1.e-9_wp ! conversion from g to Gg (further x rau0) + + 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) + + REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:) :: p_fval1d + REAL(wp), TARGET, ALLOCATABLE, SAVE, DIMENSION(:,:) :: p_fval2d + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_ptr( pvtr ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr *** + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pvtr ! j-effective transport + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zsfc,zvfc ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts ! 3D workspace + REAL(wp), DIMENSION(jpj) :: zvsum, ztsum, zssum ! 1D workspace + ! + !overturning calculation + REAL(wp), DIMENSION(jpj,jpk,nptr) :: sjk, r1_sjk, v_msf ! i-mean i-k-surface and its inverse + REAL(wp), DIMENSION(jpj,jpk,nptr) :: zt_jk, zs_jk ! i-mean T and S, j-Stream-Function + + REAL(wp), DIMENSION(jpi,jpj,jpk,nptr) :: z4d1, z4d2 + REAL(wp), DIMENSION(jpi,jpj,nptr) :: z3dtr ! i-mean T and S, j-Stream-Function + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dia_ptr') + ! + IF( PRESENT( pvtr ) ) THEN + IF( iom_use( 'zomsf' ) ) THEN ! effective MSF + DO jn = 1, nptr ! by sub-basins + z4d1(1,:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,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 = 1, jpi + z4d1(ji,:,:,jn) = z4d1(1,:,:,jn) + ENDDO + END DO + CALL iom_put( 'zomsf', z4d1 * rc_sv ) + ENDIF + IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) .OR. & + & iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN + ! define fields multiplied by scalar + zmask(:,:,:) = 0._wp + zts(:,:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, jpi + zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) + zmask(ji,jj,jk) = vmask(ji,jj,jk) * zvfc + zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid + zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc + ENDDO + ENDDO + ENDDO + ENDIF + IF( iom_use( 'sopstove' ) .OR. iom_use( 'sophtove' ) ) THEN + DO jn = 1, nptr + sjk(:,:,jn) = ptr_sjk( zmask(:,:,:), btmsk(:,:,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) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) + zs_jk(:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) * r1_sjk(:,:,jn) + v_msf(:,:,jn) = ptr_sjk( pvtr(:,:,:), btmsk34(:,:,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, nptr + z3dtr(1,:,jn) = hstr_ove(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtove', z3dtr ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_ove(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstove', z3dtr ) + ENDIF + + IF( iom_use( 'sopstbtr' ) .OR. iom_use( 'sophtbtr' ) ) THEN + ! Calculate barotropic heat and salt transport here + DO jn = 1, nptr + sjk(:,1,jn) = ptr_sj( zmask(:,:,:), btmsk(:,:,jn) ) + r1_sjk(:,1,jn) = 0._wp + WHERE( sjk(:,1,jn) /= 0._wp ) r1_sjk(:,1,jn) = 1._wp / sjk(:,1,jn) + ! + zvsum(:) = ptr_sj( pvtr(:,:,:), btmsk34(:,:,jn) ) + ztsum(:) = ptr_sj( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) + zssum(:) = ptr_sj( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) + 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, nptr + z3dtr(1,:,jn) = hstr_btr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtbtr', z3dtr ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_btr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopstbtr', z3dtr ) + ENDIF + ! + ELSE + ! + zmask(:,:,:) = 0._wp + zts(:,:,:,:) = 0._wp + IF( iom_use( 'zotem' ) .OR. iom_use( 'zosal' ) .OR. iom_use( 'zosrf' ) ) THEN ! i-mean i-k-surface + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zsfc = e1t(ji,jj) * e3t_n(ji,jj,jk) + zmask(ji,jj,jk) = tmask(ji,jj,jk) * zsfc + zts(ji,jj,jk,jp_tem) = tsn(ji,jj,jk,jp_tem) * zsfc + zts(ji,jj,jk,jp_sal) = tsn(ji,jj,jk,jp_sal) * zsfc + END DO + END DO + END DO + ! + DO jn = 1, nptr + zmask(1,:,:) = ptr_sjk( zmask(:,:,:), btmsk(:,:,jn) ) + z4d1(:,:,:,jn) = zmask(:,:,:) + ENDDO + CALL iom_put( 'zosrf', z4d1 ) + ! + DO jn = 1, nptr + z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_tem), btmsk(:,:,jn) ) & + & / MAX( z4d1(1,:,:,jn), 10.e-15 ) + DO ji = 1, jpi + z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zotem', z4d2 ) + ! + DO jn = 1, nptr + z4d2(1,:,:,jn) = ptr_sjk( zts(:,:,:,jp_sal), btmsk(:,:,jn) ) & + & / MAX( z4d1(1,:,:,jn), 10.e-15 ) + DO ji = 1, jpi + z4d2(ji,:,:,jn) = z4d2(1,:,:,jn) + ENDDO + ENDDO + CALL iom_put( 'zosal', z4d2 ) + ! + ENDIF + ! + ! ! Advective and diffusive heat and salt transport + IF( iom_use( 'sophtadv' ) .OR. iom_use( 'sopstadv' ) ) THEN + ! + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_adv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtadv', z3dtr ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_adv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 1, 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, nptr + z3dtr(1,:,jn) = hstr_ldf(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtldf', z3dtr ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_ldf(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 1, 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, nptr + z3dtr(1,:,jn) = hstr_eiv(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophteiv', z3dtr ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_eiv(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sopsteiv', z3dtr ) + ENDIF + ! + IF( iom_use( 'sopstvtr' ) .OR. iom_use( 'sophtvtr' ) ) THEN + zts(:,:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, jpi + zvfc = e1v(ji,jj) * e3v_n(ji,jj,jk) + zts(ji,jj,jk,jp_tem) = (tsn(ji,jj,jk,jp_tem)+tsn(ji,jj+1,jk,jp_tem)) * 0.5 * zvfc !Tracers averaged onto V grid + zts(ji,jj,jk,jp_sal) = (tsn(ji,jj,jk,jp_sal)+tsn(ji,jj+1,jk,jp_sal)) * 0.5 * zvfc + ENDDO + ENDDO + ENDDO + CALL dia_ptr_hst( jp_tem, 'vtr', zts(:,:,:,jp_tem) ) + CALL dia_ptr_hst( jp_sal, 'vtr', zts(:,:,:,jp_sal) ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_vtr(:,jp_tem,jn) * rc_pwatt ! (conversion in PW) + DO ji = 1, jpi + z3dtr(ji,:,jn) = z3dtr(1,:,jn) + ENDDO + ENDDO + CALL iom_put( 'sophtvtr', z3dtr ) + DO jn = 1, nptr + z3dtr(1,:,jn) = hstr_vtr(:,jp_sal,jn) * rc_ggram ! (conversion in Gg) + DO ji = 1, 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 + ! + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_ptr') + ! + END SUBROUTINE dia_ptr + + + SUBROUTINE dia_ptr_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_init *** + !! + !! ** Purpose : Initialization, namelist read + !!---------------------------------------------------------------------- + INTEGER :: inum, jn, ios, ierr ! local integers + !! + NAMELIST/namptr/ ln_diaptr, ln_subbas + REAL(wp), DIMENSION(jpi,jpj) :: zmsk + !!---------------------------------------------------------------------- + + + REWIND( numnam_ref ) ! Namelist namptr in reference namelist : Poleward transport + READ ( numnam_ref, namptr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namptr in configuration namelist : Poleward transport + READ ( numnam_cfg, namptr, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namptr in configuration namelist' ) + IF(lwm) WRITE ( numond, namptr ) + + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dia_ptr_init : poleward transport and msf initialization' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namptr : set ptr parameters' + WRITE(numout,*) ' Poleward heat & salt transport (T) or not (F) ln_diaptr = ', ln_diaptr + ENDIF + + IF( ln_diaptr ) THEN + ! + IF( dia_ptr_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dia_ptr_init : unable to allocate arrays' ) + + rc_pwatt = rc_pwatt * rau0_rcp ! conversion from K.s-1 to PetaWatt + rc_ggram = rc_ggram * rau0 ! 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(:,:) + CALL iom_open( 'subbasins', inum, ldstop = .FALSE. ) + CALL iom_get( inum, jpdom_data, 'atlmsk', btmsk(:,:,2) ) ! Atlantic basin + CALL iom_get( inum, jpdom_data, 'pacmsk', btmsk(:,:,3) ) ! Pacific basin + CALL iom_get( inum, jpdom_data, 'indmsk', btmsk(:,:,4) ) ! Indian basin + CALL iom_close( inum ) + btmsk(:,:,5) = MAX ( btmsk(:,:,3), btmsk(:,:,4) ) ! Indo-Pacific basin + DO jn = 2, nptr + 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, nptr + 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 ! + ! + ENDIF + ! + END SUBROUTINE dia_ptr_init + + + SUBROUTINE dia_ptr_hst( ktra, cptr, pva ) + !!---------------------------------------------------------------------- + !! *** 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(jpi,jpj,jpk), INTENT(in) :: pva ! 3D input array of advection/diffusion + INTEGER :: jn ! + + ! + IF( cptr == 'adv' ) THEN + IF( ktra == jp_tem ) THEN + DO jn = 1, nptr + hstr_adv(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + IF( ktra == jp_sal ) THEN + DO jn = 1, nptr + hstr_adv(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + ENDIF + ! + IF( cptr == 'ldf' ) THEN + IF( ktra == jp_tem ) THEN + DO jn = 1, nptr + hstr_ldf(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + IF( ktra == jp_sal ) THEN + DO jn = 1, nptr + hstr_ldf(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + ENDIF + ! + IF( cptr == 'eiv' ) THEN + IF( ktra == jp_tem ) THEN + DO jn = 1, nptr + hstr_eiv(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + IF( ktra == jp_sal ) THEN + DO jn = 1, nptr + hstr_eiv(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + ENDIF + ! + IF( cptr == 'vtr' ) THEN + IF( ktra == jp_tem ) THEN + DO jn = 1, nptr + hstr_vtr(:,jp_tem,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + IF( ktra == jp_sal ) THEN + DO jn = 1, nptr + hstr_vtr(:,jp_sal,jn) = ptr_sj( pva(:,:,:), btmsk(:,:,jn) ) + ENDDO + ENDIF + ENDIF + ! + END SUBROUTINE dia_ptr_hst + + + FUNCTION dia_ptr_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dia_ptr_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: dia_ptr_alloc ! return value + INTEGER, DIMENSION(3) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + IF( .NOT. ALLOCATED( btmsk ) ) THEN + ALLOCATE( btmsk(jpi,jpj,nptr) , btmsk34(jpi,jpj,nptr), & + & hstr_adv(jpj,jpts,nptr), hstr_eiv(jpj,jpts,nptr), & + & hstr_ove(jpj,jpts,nptr), hstr_btr(jpj,jpts,nptr), & + & hstr_ldf(jpj,jpts,nptr), hstr_vtr(jpj,jpts,nptr), STAT=ierr(1) ) + ! + ALLOCATE( p_fval1d(jpj), p_fval2d(jpj,jpk), 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( pva, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sj_3d *** + !! + !! ** Purpose : i-k sum computation of a j-flux array + !! + !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). + !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) + !! + !! ** Action : - p_fval: i-k-mean poleward flux of pva + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in), DIMENSION(jpi,jpj,jpk) :: pva ! 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 + INTEGER :: ijpj ! ??? + REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + p_fval => p_fval1d + + ijpj = jpj + p_fval(:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! Vector opt. + p_fval(jj) = p_fval(jj) + pva(ji,jj,jk) * pmsk(ji,jj) * tmask_i(ji,jj) + END DO + END DO + END DO +#if defined key_mpp_mpi + CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl) +#endif + ! + END FUNCTION ptr_sj_3d + + + FUNCTION ptr_sj_2d( pva, pmsk ) RESULT ( p_fval ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ptr_sj_2d *** + !! + !! ** Purpose : "zonal" and vertical sum computation of a i-flux array + !! + !! ** Method : - i-k sum of pva using the interior 2D vmask (vmask_i). + !! pva is supposed to be a masked flux (i.e. * vmask*e1v*e3v) + !! + !! ** Action : - p_fval: i-k-mean poleward flux of pva + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pva ! mask flux array at V-point + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj) :: pmsk ! Optional 2D basin mask + ! + INTEGER :: ji,jj ! dummy loop arguments + INTEGER :: ijpj ! ??? + REAL(wp), POINTER, DIMENSION(:) :: p_fval ! function value + !!-------------------------------------------------------------------- + ! + p_fval => p_fval1d + + ijpj = jpj + p_fval(:) = 0._wp + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! Vector opt. + p_fval(jj) = p_fval(jj) + pva(ji,jj) * pmsk(ji,jj) * tmask_i(ji,jj) + END DO + END DO +#if defined key_mpp_mpi + CALL mpp_sum( 'diaptr', p_fval, ijpj, ncomm_znl ) +#endif + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! Vector opt. + p_fval(ji,jj) = p_fval(ji,jj-1) + pva(ji,jj) * tmask_i(ji,jj) + END DO + END DO + CALL lbc_lnk( 'diaptr', p_fval, 'U', -1. ) + 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 pva using the interior 2D vmask (vmask_i). + !! + !! ** Action : - p_fval: i-mean poleward flux of pva + !!---------------------------------------------------------------------- + !! + IMPLICIT none + REAL(wp) , INTENT(in), DIMENSION(jpi,jpj,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), POINTER, DIMENSION(:,:) :: p_fval ! return function value +#if defined key_mpp_mpi + INTEGER, DIMENSION(1) :: ish + INTEGER, DIMENSION(2) :: ish2 + INTEGER :: ijpjjpk + REAL(wp), DIMENSION(jpj*jpk) :: zwork ! mask flux array at V-point +#endif + !!-------------------------------------------------------------------- + ! + p_fval => p_fval2d + + p_fval(:,:) = 0._wp + ! + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! Vector opt. + 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 + ! +#if defined key_mpp_mpi + ijpjjpk = jpj*jpk + ish(1) = ijpjjpk ; ish2(1) = jpj ; ish2(2) = jpk + zwork(1:ijpjjpk) = RESHAPE( p_fval, ish ) + CALL mpp_sum( 'diaptr', zwork, ijpjjpk, ncomm_znl ) + p_fval(:,:) = RESHAPE( zwork, ish2 ) +#endif + ! + END FUNCTION ptr_sjk + + + !!====================================================================== +END MODULE diaptr diff --git a/NEMO_4.0.4_surge/src/OCE/DIA/diawri.F90 b/NEMO_4.0.4_surge/src/OCE/DIA/diawri.F90 new file mode 100644 index 0000000..43f5317 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIA/diawri.F90 @@ -0,0 +1,969 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 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 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 eosbn2 +#if defined key_si3 + USE ice + USE icewri +#endif + USE lib_mpp ! MPP library + USE timing ! preformance summary + USE diurnal_bulk ! diurnal warm layer + USE cool_skin ! 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 :: ndex(1) ! ??? + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_hT, ndex_hU, ndex_hV + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_T, ndex_U, ndex_V + INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: ndex_bT + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if defined key_iomput + !!---------------------------------------------------------------------- + !! 'key_iomput' use IOM library + !!---------------------------------------------------------------------- + INTEGER FUNCTION dia_wri_alloc() + ! + dia_wri_alloc = 0 + ! + END FUNCTION dia_wri_alloc + + + SUBROUTINE dia_wri( kt ) + !!--------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbot ! local integer + REAL(wp):: zztmp , zztmpx ! local scalar + REAL(wp):: zztmp2, zztmpy ! - - + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3d ! 3D workspace + CHARACTER(len=4),SAVE :: ttype , stype ! temperature and salinity type + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF( ln_TEOS10 ) THEN + IF ( iom_use("toce_pot") .OR. iom_use("soce_pra") .OR. iom_use("sst_pot") .OR. iom_use("sss_pra") & + & .OR. iom_use("sbt_pot") .OR. iom_use("sbs_pra") .OR. iom_use("sstgrad_pot") .OR. iom_use("sstgrad2_pot") & + & .OR. iom_use("tosmint_pot") .OR. iom_use("somint_pra")) THEN + CALL ctl_stop( 'diawri: potential temperature and practical salinity not available with ln_TEOS10' ) + ELSE + ttype='con' ; stype='abs' ! teos-10 using conservative temperature and absolute salinity + ENDIF + ELSE IF( ln_EOS80 ) THEN + IF ( iom_use("toce_con") .OR. iom_use("soce_abs") .OR. iom_use("sst_con") .OR. iom_use("sss_abs") & + & .OR. iom_use("sbt_con") .OR. iom_use("sbs_abs") .OR. iom_use("sstgrad_con") .OR. iom_use("sstgrad2_con") & + & .OR. iom_use("tosmint_con") .OR. iom_use("somint_abs")) THEN + CALL ctl_stop( 'diawri: conservative temperature and absolute salinity not available with ln_EOS80' ) + ELSE + ttype='pot' ; stype='pra' ! eos-80 using potential temperature and practical salinity + ENDIF + ELSE IF ( ln_SEOS) THEN + ttype='seos' ; stype='seos' ! seos using Simplified Equation of state + ENDIF + ENDIF + + IF( ln_timing ) CALL timing_start('dia_wri') + ! + ! Output the initial state and forcings + IF( ninist == 1 ) THEN + CALL dia_wri_state( 'output.init' ) + ninist = 0 + ENDIF + + ! 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( "e3t" , e3t_n(:,:,:) ) + CALL iom_put( "e3u" , e3u_n(:,:,:) ) + CALL iom_put( "e3v" , e3v_n(:,:,:) ) + CALL iom_put( "e3w" , e3w_n(:,:,:) ) + IF( iom_use("e3tdef") ) & + CALL iom_put( "e3tdef" , ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 ) + + IF( ll_wd ) THEN + CALL iom_put( "ssh" , (sshn+ssh_ref)*tmask(:,:,1) ) ! sea surface height (brought back to the reference used for wetting and drying) + ELSE + CALL iom_put( "ssh" , sshn ) ! sea surface height + ENDIF + + IF( iom_use("wetdep") ) & ! wet depth + CALL iom_put( "wetdep" , ht_0(:,:) + sshn(:,:) ) + + CALL iom_put( "toce_"//ttype, tsn(:,:,:,jp_tem) ) ! 3D temperature + CALL iom_put( "sst_"//ttype, tsn(:,:,1,jp_tem) ) ! surface temperature + IF ( iom_use("sbt_"//ttype) ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikbot = mbkt(ji,jj) + z2d(ji,jj) = tsn(ji,jj,ikbot,jp_tem) + END DO + END DO + CALL iom_put( "sbt_"//ttype, z2d ) ! bottom temperature + ENDIF + + CALL iom_put( "soce_"//stype, tsn(:,:,:,jp_sal) ) ! 3D salinity + CALL iom_put( "sss_"//stype, tsn(:,:,1,jp_sal) ) ! surface salinity + IF ( iom_use("sbs_"//stype) ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikbot = mbkt(ji,jj) + z2d(ji,jj) = tsn(ji,jj,ikbot,jp_sal) + END DO + END DO + CALL iom_put( "sbs_"//stype, z2d ) ! bottom salinity + ENDIF + + CALL iom_put( "rhop", rhop(:,:,:) ) ! 3D potential density (sigma0) + + IF ( iom_use("taubot") ) THEN ! bottom stress + zztmp = rau0 * 0.25 + z2d(:,:) = 0._wp + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zztmp2 = ( ( rCdU_bot(ji+1,jj)+rCdU_bot(ji ,jj) ) * un(ji ,jj,mbku(ji ,jj)) )**2 & + & + ( ( rCdU_bot(ji ,jj)+rCdU_bot(ji-1,jj) ) * un(ji-1,jj,mbku(ji-1,jj)) )**2 & + & + ( ( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj ) ) * vn(ji,jj ,mbkv(ji,jj )) )**2 & + & + ( ( rCdU_bot(ji,jj )+rCdU_bot(ji,jj-1) ) * vn(ji,jj-1,mbkv(ji,jj-1)) )**2 + z2d(ji,jj) = zztmp * SQRT( zztmp2 ) * tmask(ji,jj,1) + ! + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) + CALL iom_put( "taubot", z2d ) + ENDIF + + IF( iom_use("uwnd") ) CALL iom_put( "uwnd" , uwnd*tmask(:,:,1) ) + IF( iom_use("vwnd") ) CALL iom_put( "vwnd" , vwnd*tmask(:,:,1) ) + + CALL iom_put( "uoce", un(:,:,:) ) ! 3D i-current + CALL iom_put( "ssu", un(:,:,1) ) ! surface i-current + IF ( iom_use("sbu") ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikbot = mbku(ji,jj) + z2d(ji,jj) = un(ji,jj,ikbot) + END DO + END DO + CALL iom_put( "sbu", z2d ) ! bottom i-current + ENDIF + + CALL iom_put( "voce", vn(:,:,:) ) ! 3D j-current + CALL iom_put( "ssv", vn(:,:,1) ) ! surface j-current + IF ( iom_use("sbv") ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + ikbot = mbkv(ji,jj) + z2d(ji,jj) = vn(ji,jj,ikbot) + END DO + END DO + CALL iom_put( "sbv", z2d ) ! bottom j-current + ENDIF + + IF( ln_zad_Aimp ) wn = wn + wi ! Recombine explicit and implicit parts of vertical velocity for diagnostic output + ! + CALL iom_put( "woce", wn ) ! vertical velocity + 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. + z2d(:,:) = rau0 * e1e2t(:,:) + DO jk = 1, jpk + z3d(:,:,jk) = wn(:,:,jk) * z2d(:,:) + END DO + CALL iom_put( "w_masstr" , z3d ) + IF( iom_use('w_masstr2') ) CALL iom_put( "w_masstr2", z3d(:,:,:) * z3d(:,:,:) ) + ENDIF + ! + IF( ln_zad_Aimp ) wn = wn - wi ! Remove implicit part of vertical velocity that was added for diagnostic output + + 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("sstgrad_"//ttype) .OR. iom_use("sstgrad2_"//ttype) ) THEN + DO jj = 2, jpjm1 ! sst gradient + DO ji = fs_2, fs_jpim1 ! vector opt. + zztmp = tsn(ji,jj,1,jp_tem) + zztmpx = ( tsn(ji+1,jj,1,jp_tem) - zztmp ) * r1_e1u(ji,jj) + ( zztmp - tsn(ji-1,jj ,1,jp_tem) ) * r1_e1u(ji-1,jj) + zztmpy = ( tsn(ji,jj+1,1,jp_tem) - zztmp ) * r1_e2v(ji,jj) + ( zztmp - tsn(ji ,jj-1,1,jp_tem) ) * r1_e2v(ji,jj-1) + z2d(ji,jj) = 0.25 * ( zztmpx * zztmpx + zztmpy * zztmpy ) & + & * umask(ji,jj,1) * umask(ji-1,jj,1) * vmask(ji,jj,1) * umask(ji,jj-1,1) + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'T', 1. ) + CALL iom_put( "sstgrad2_"//ttype, z2d ) ! square of module of sst gradient + z2d(:,:) = SQRT( z2d(:,:) ) + CALL iom_put( "sstgrad_"//ttype , z2d ) ! module of sst gradient + ENDIF + + ! heat and salt contents + IF( iom_use("heatc") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) + END DO + END DO + END DO + CALL iom_put( "heatc", rau0_rcp * z2d ) ! vertically integrated heat content (J/m2) + ENDIF + + IF( iom_use("saltc") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) * tmask(ji,jj,jk) + END DO + END DO + END DO + CALL iom_put( "saltc", rau0 * z2d ) ! vertically integrated salt content (PSU*kg/m2) + ENDIF + ! + IF ( iom_use("eken") ) THEN + z3d(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zztmp = 0.25_wp * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + z3d(ji,jj,jk) = zztmp * ( un(ji-1,jj,jk)**2 * e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) & + & + un(ji ,jj,jk)**2 * e2u(ji ,jj) * e3u_n(ji ,jj,jk) & + & + vn(ji,jj-1,jk)**2 * e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) & + & + vn(ji,jj ,jk)**2 * e1v(ji,jj ) * e3v_n(ji,jj ,jk) ) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z3d, 'T', 1. ) + CALL iom_put( "eken", z3d ) ! kinetic energy + ENDIF + ! + CALL iom_put( "hdiv", hdivn ) ! Horizontal divergence + ! + IF( iom_use("u_masstr") .OR. iom_use("u_masstr_vint") .OR. iom_use("u_heattr") .OR. iom_use("u_salttr") ) THEN + z3d(:,:,jpk) = 0.e0 + z2d(:,:) = 0.e0 + DO jk = 1, jpkm1 + z3d(:,:,jk) = rau0 * un(:,:,jk) * e2u(:,:) * e3u_n(:,:,jk) * umask(:,:,jk) + z2d(:,:) = z2d(:,:) + z3d(:,:,jk) + END DO + CALL iom_put( "u_masstr" , z3d ) ! mass transport in i-direction + CALL iom_put( "u_masstr_vint", z2d ) ! mass transport in i-direction vertical sum + ENDIF + + IF( iom_use("u_heattr") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji+1,jj,jk,jp_tem) ) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) + CALL iom_put( "u_heattr", 0.5*rcp * z2d ) ! heat transport in i-direction + ENDIF + + IF( iom_use("u_salttr") ) THEN + z2d(:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji+1,jj,jk,jp_sal) ) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'U', -1. ) + CALL iom_put( "u_salttr", 0.5 * z2d ) ! heat transport in i-direction + ENDIF + + + IF( iom_use("v_masstr") .OR. iom_use("v_heattr") .OR. iom_use("v_salttr") ) THEN + z3d(:,:,jpk) = 0.e0 + DO jk = 1, jpkm1 + z3d(:,:,jk) = rau0 * vn(:,:,jk) * e1v(:,:) * e3v_n(:,:,jk) * vmask(:,:,jk) + END DO + CALL iom_put( "v_masstr", z3d ) ! mass transport in j-direction + ENDIF + + IF( iom_use("v_heattr") ) THEN + z2d(:,:) = 0.e0 + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_tem) + tsn(ji,jj+1,jk,jp_tem) ) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) + CALL iom_put( "v_heattr", 0.5*rcp * z2d ) ! heat transport in j-direction + ENDIF + + IF( iom_use("v_salttr") ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + z3d(ji,jj,jk) * ( tsn(ji,jj,jk,jp_sal) + tsn(ji,jj+1,jk,jp_sal) ) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'V', -1. ) + CALL iom_put( "v_salttr", 0.5 * z2d ) ! heat transport in j-direction + ENDIF + + IF( iom_use("tosmint_"//ttype) ) THEN + z2d(:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_tem) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) + CALL iom_put( "tosmint_"//ttype, rau0 * z2d ) ! Vertical integral of temperature + ENDIF + IF( iom_use("somint_"//stype) ) THEN + z2d(:,:)=0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z2d(ji,jj) = z2d(ji,jj) + e3t_n(ji,jj,jk) * tsn(ji,jj,jk,jp_sal) + END DO + END DO + END DO + CALL lbc_lnk( 'diawri', z2d, 'T', -1. ) + CALL iom_put( "somint_"//stype, rau0 * z2d ) ! Vertical integral of salinity + ENDIF + + CALL iom_put( "bn2", rn2 ) ! Brunt-Vaisala buoyancy frequency (N^2) + ! + + IF (ln_dia25h) CALL dia_25h( kt ) ! 25h averaging + + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri + +#else + !!---------------------------------------------------------------------- + !! Default option use IOIPSL library + !!---------------------------------------------------------------------- + + INTEGER FUNCTION dia_wri_alloc() + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: ierr + !!---------------------------------------------------------------------- + IF( nn_write == -1 ) THEN + dia_wri_alloc = 0 + ELSE + ierr = 0 + ALLOCATE( ndex_hT(jpi*jpj) , ndex_T(jpi*jpj*jpk) , & + & ndex_hU(jpi*jpj) , ndex_U(jpi*jpj*jpk) , & + & ndex_hV(jpi*jpj) , ndex_V(jpi*jpj*jpk) , STAT=ierr(1) ) + ! + dia_wri_alloc = MAXVAL(ierr) + CALL mpp_sum( 'diawri', dia_wri_alloc ) + ! + ENDIF + ! + END FUNCTION dia_wri_alloc + + + SUBROUTINE dia_wri( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dia_wri *** + !! + !! ** Purpose : Standard output of opa: dynamics and tracer fields + !! NETCDF format is used by default + !! + !! ** Method : At the beginning of the first time step (nit000), + !! define all the NETCDF files and fields + !! At each time step call histdef to compute the mean if ncessary + !! Each nn_write time step, output the instantaneous or mean fields + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + LOGICAL :: ll_print = .FALSE. ! =T print and flush numout + CHARACTER (len=40) :: clhstnam, clop, clmx ! local names + INTEGER :: inum = 11 ! temporary logical unit + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ierr ! error code return from allocation + INTEGER :: iimi, iima, ipk, it, itmod, ijmi, ijma ! local integers + INTEGER :: jn, ierror ! local integers + REAL(wp) :: zsto, zout, zmax, zjulian ! local scalars + ! + REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zw3d ! 3D workspace + !!---------------------------------------------------------------------- + ! + IF( ninist == 1 ) THEN !== Output the initial state and forcings ==! + CALL dia_wri_state( 'output.init' ) + ninist = 0 + ENDIF + ! + IF( nn_write == -1 ) RETURN ! we will never do any output + ! + IF( ln_timing ) CALL timing_start('dia_wri') + ! + ! 0. Initialisation + ! ----------------- + + ll_print = .FALSE. ! local variable for debugging + ll_print = ll_print .AND. lwp + + ! Define frequency of output and means + clop = "x" ! no use of the mask value (require less cpu time and otherwise the model crashes) +#if defined key_diainstant + zsto = nn_write * rdt + clop = "inst("//TRIM(clop)//")" +#else + zsto=rdt + clop = "ave("//TRIM(clop)//")" +#endif + zout = nn_write * rdt + zmax = ( nitend - nit000 + 1 ) * rdt + + ! Define indices of the horizontal output zoom and vertical limit storage + iimi = 1 ; iima = jpi + ijmi = 1 ; ijma = jpj + ipk = jpk + + ! define time axis + it = kt + itmod = kt - nit000 + 1 + + + ! 1. Define NETCDF files and fields at beginning of first time step + ! ----------------------------------------------------------------- + + IF( kt == nit000 ) THEN + + ! Define the NETCDF files (one per grid) + + ! Compute julian date from starting date of the run + CALL ymds2ju( nyear, nmonth, nday, rdt, zjulian ) + zjulian = zjulian - adatrj ! set calendar origin to the beginning of the experiment + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'Date 0 used :', nit000, ' YEAR ', nyear, & + & ' MONTH ', nmonth, ' DAY ', nday, 'Julian day : ', zjulian + IF(lwp)WRITE(numout,*) ' indexes of zoom = ', iimi, iima, ijmi, ijma, & + ' limit storage in depth = ', ipk + + ! WRITE root name in date.file for use by postpro + IF(lwp) THEN + CALL dia_nam( clhstnam, nn_write,' ' ) + CALL ctl_opn( inum, 'date.file', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + WRITE(inum,*) clhstnam + CLOSE(inum) + ENDIF + + ! Define the T grid FILE ( nid_T ) + + CALL dia_nam( clhstnam, nn_write, 'grid_T' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rdt, nh_T, nid_T, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_T, "deptht", "Vertical T levels", & ! Vertical grid: gdept + & "m", ipk, gdept_1d, nz_T, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, tmask, 1, 1., ndex_T , ndim_T ) ! volume + CALL wheneq( jpi*jpj , tmask, 1, 1., ndex_hT, ndim_hT ) ! surface + ! + IF( ln_icebergs ) THEN + ! + !! allocation cant go in dia_wri_alloc because ln_icebergs is only set after + !! that routine is called from nemogcm, so do it here immediately before its needed + ALLOCATE( ndex_bT(jpi*jpj*nclasses), STAT=ierror ) + CALL mpp_sum( 'diawri', ierror ) + IF( ierror /= 0 ) THEN + CALL ctl_stop('dia_wri: failed to allocate iceberg diagnostic array') + RETURN + ENDIF + ! + !! iceberg vertical coordinate is class number + CALL histvert( nid_T, "class", "Iceberg class", & ! Vertical grid: class + & "number", nclasses, class_num, nb_T ) + ! + !! each class just needs the surface index pattern + ndim_bT = 3 + DO jn = 1,nclasses + ndex_bT((jn-1)*jpi*jpj+1:jn*jpi*jpj) = ndex_hT(1:jpi*jpj) + ENDDO + ! + ENDIF + + ! Define the U grid FILE ( nid_U ) + + CALL dia_nam( clhstnam, nn_write, 'grid_U' ) + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam ! filename + CALL histbeg( clhstnam, jpi, glamu, jpj, gphiu, & ! Horizontal grid: glamu and gphiu + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rdt, nh_U, nid_U, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_U, "depthu", "Vertical U levels", & ! Vertical grid: gdept + & "m", ipk, gdept_1d, nz_U, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, umask, 1, 1., ndex_U , ndim_U ) ! volume + CALL wheneq( jpi*jpj , umask, 1, 1., ndex_hU, ndim_hU ) ! surface + + ! Define the V grid FILE ( nid_V ) + + CALL dia_nam( clhstnam, nn_write, 'grid_V' ) ! filename + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam + CALL histbeg( clhstnam, jpi, glamv, jpj, gphiv, & ! Horizontal grid: glamv and gphiv + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rdt, nh_V, nid_V, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_V, "depthv", "Vertical V levels", & ! Vertical grid : gdept + & "m", ipk, gdept_1d, nz_V, "down" ) + ! ! Index of ocean points + CALL wheneq( jpi*jpj*ipk, vmask, 1, 1., ndex_V , ndim_V ) ! volume + CALL wheneq( jpi*jpj , vmask, 1, 1., ndex_hV, ndim_hV ) ! surface + + ! Define the W grid FILE ( nid_W ) + + CALL dia_nam( clhstnam, nn_write, 'grid_W' ) ! filename + IF(lwp) WRITE(numout,*) " Name of NETCDF file ", clhstnam + CALL histbeg( clhstnam, jpi, glamt, jpj, gphit, & ! Horizontal grid: glamt and gphit + & iimi, iima-iimi+1, ijmi, ijma-ijmi+1, & + & nit000-1, zjulian, rdt, nh_W, nid_W, domain_id=nidom, snc4chunks=snc4set ) + CALL histvert( nid_W, "depthw", "Vertical W levels", & ! Vertical grid: gdepw + & "m", ipk, gdepw_1d, nz_W, "down" ) + + + ! Declare all the output fields as NETCDF variables + + ! !!! nid_T : 3D + CALL histdef( nid_T, "votemper", "Temperature" , "C" , & ! tn + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vosaline", "Salinity" , "PSU" , & ! sn + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + IF( .NOT.ln_linssh ) THEN + CALL histdef( nid_T, "vovvle3t", "Level thickness" , "m" ,& ! e3t_n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vovvldep", "T point depth" , "m" ,& ! e3t_n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + CALL histdef( nid_T, "vovvldef", "Squared level deformation" , "%^2" ,& ! e3t_n + & jpi, jpj, nh_T, ipk, 1, ipk, nz_T, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_T : 2D + CALL histdef( nid_T, "sosstsst", "Sea Surface temperature" , "C" , & ! sst + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosaline", "Sea Surface Salinity" , "PSU" , & ! sss + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sossheig", "Sea Surface Height" , "m" , & ! ssh + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowaflup", "Net Upward Water Flux" , "Kg/m2/s", & ! (emp-rnf) + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sorunoff", "River runoffs" , "Kg/m2/s", & ! runoffs + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosfldow", "downward salt flux" , "PSU/m2/s", & ! sfx + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + IF( ln_linssh ) THEN + CALL histdef( nid_T, "sosst_cd", "Concentration/Dilution term on temperature" & ! emp * tsn(:,:,1,jp_tem) + & , "KgC/m2/s", & ! sosst_cd + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosss_cd", "Concentration/Dilution term on salinity" & ! emp * tsn(:,:,1,jp_sal) + & , "KgPSU/m2/s",& ! sosss_cd + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + CALL histdef( nid_T, "sohefldo", "Net Downward Heat Flux" , "W/m2" , & ! qns + qsr + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "soshfldo", "Shortwave Radiation" , "W/m2" , & ! qsr + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "somixhgt", "Turbocline Depth" , "m" , & ! hmld + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "somxl010", "Mixed Layer Depth 0.01" , "m" , & ! hmlp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "soicecov", "Ice fraction" , "[0,1]" , & ! fr_i + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowindsp", "wind speed at 10m" , "m/s" , & ! wndm + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +! + IF( ln_icebergs ) THEN + CALL histdef( nid_T, "calving" , "calving mass input" , "kg/s" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "calving_heat" , "calving heat flux" , "XXXX" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_floating_melt" , "Melt rate of icebergs + bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_stored_ice" , "Accumulated ice mass by class" , "kg" , & + & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout ) + IF( ln_bergdia ) THEN + CALL histdef( nid_T, "berg_melt" , "Melt rate of icebergs" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_buoy_melt" , "Buoyancy component of iceberg melt rate" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_eros_melt" , "Erosion component of iceberg melt rate" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_conv_melt" , "Convective component of iceberg melt rate", "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_virtual_area" , "Virtual coverage by icebergs" , "m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_src" , "Mass source of bergy bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_melt" , "Melt rate of bergy bits" , "kg/m2/s", & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "bits_mass" , "Bergy bit density field" , "kg/m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_mass" , "Iceberg density field" , "kg/m2" , & + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "berg_real_calving" , "Calving into iceberg class" , "kg/s" , & + & jpi, jpj, nh_T, nclasses , 1, nclasses , nb_T , 32, clop, zsto, zout ) + ENDIF + ENDIF + + IF( ln_ssr ) THEN + CALL histdef( nid_T, "sohefldp", "Surface Heat Flux: Damping" , "W/m2" , & ! qrp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sowafldp", "Surface Water Flux: Damping" , "Kg/m2/s", & ! erp + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sosafldp", "Surface salt flux: damping" , "Kg/m2/s", & ! erp * sn + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + ENDIF + + clmx ="l_max(only(x))" ! max index on a period +! CALL histdef( nid_T, "sobowlin", "Bowl Index" , "W-point", & ! bowl INDEX +! & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clmx, zsto, zout ) +#if defined key_diahth + CALL histdef( nid_T, "sothedep", "Thermocline Depth" , "m" , & ! hth + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "so20chgt", "Depth of 20C isotherm" , "m" , & ! hd20 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "so28chgt", "Depth of 28C isotherm" , "m" , & ! hd28 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) + CALL histdef( nid_T, "sohtc300", "Heat content 300 m" , "J/m2" , & ! htc3 + & jpi, jpj, nh_T, 1 , 1, 1 , -99 , 32, clop, zsto, zout ) +#endif + + CALL histend( nid_T, snc4chunks=snc4set ) + + ! !!! nid_U : 3D + CALL histdef( nid_U, "vozocrtx", "Zonal Current" , "m/s" , & ! un + & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout ) + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_U, "sdzocrtx", "Stokes Drift Zonal Current" , "m/s" , & ! usd + & jpi, jpj, nh_U, ipk, 1, ipk, nz_U, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_U : 2D + CALL histdef( nid_U, "sozotaux", "Wind Stress along i-axis" , "N/m2" , & ! utau + & jpi, jpj, nh_U, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + + CALL histend( nid_U, snc4chunks=snc4set ) + + ! !!! nid_V : 3D + CALL histdef( nid_V, "vomecrty", "Meridional Current" , "m/s" , & ! vn + & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout ) + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_V, "sdmecrty", "Stokes Drift Meridional Current" , "m/s" , & ! vsd + & jpi, jpj, nh_V, ipk, 1, ipk, nz_V, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_V : 2D + CALL histdef( nid_V, "sometauy", "Wind Stress along j-axis" , "N/m2" , & ! vtau + & jpi, jpj, nh_V, 1 , 1, 1 , - 99, 32, clop, zsto, zout ) + + CALL histend( nid_V, snc4chunks=snc4set ) + + ! !!! nid_W : 3D + CALL histdef( nid_W, "vovecrtz", "Vertical Velocity" , "m/s" , & ! wn + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + CALL histdef( nid_W, "votkeavt", "Vertical Eddy Diffusivity" , "m2/s" , & ! avt + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + CALL histdef( nid_W, "votkeavm", "Vertical Eddy Viscosity" , "m2/s" , & ! avm + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + + IF( ln_zdfddm ) THEN + CALL histdef( nid_W,"voddmavs","Salt Vertical Eddy Diffusivity" , "m2/s" , & ! avs + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + ENDIF + + IF( ln_wave .AND. ln_sdw) THEN + CALL histdef( nid_W, "sdvecrtz", "Stokes Drift Vertical Current" , "m/s" , & ! wsd + & jpi, jpj, nh_W, ipk, 1, ipk, nz_W, 32, clop, zsto, zout ) + ENDIF + ! !!! nid_W : 2D + CALL histend( nid_W, snc4chunks=snc4set ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'End of NetCDF Initialization' + IF(ll_print) CALL FLUSH(numout ) + + ENDIF + + ! 2. Start writing data + ! --------------------- + + ! ndex(1) est utilise ssi l'avant dernier argument est different de + ! la taille du tableau en sortie. Dans ce cas , l'avant dernier argument + ! donne le nombre d'elements, et ndex la liste des indices a sortir + + IF( lwp .AND. MOD( itmod, nn_write ) == 0 ) THEN + WRITE(numout,*) 'dia_wri : write model outputs in NetCDF files at ', kt, 'time-step' + WRITE(numout,*) '~~~~~~ ' + ENDIF + + IF( .NOT.ln_linssh ) THEN + CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) * e3t_n(:,:,:) , ndim_T , ndex_T ) ! heat content + CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) * e3t_n(:,:,:) , ndim_T , ndex_T ) ! salt content + CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) * e3t_n(:,:,1) , ndim_hT, ndex_hT ) ! sea surface heat content + CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) * e3t_n(:,:,1) , ndim_hT, ndex_hT ) ! sea surface salinity content + ELSE + CALL histwrite( nid_T, "votemper", it, tsn(:,:,:,jp_tem) , ndim_T , ndex_T ) ! temperature + CALL histwrite( nid_T, "vosaline", it, tsn(:,:,:,jp_sal) , ndim_T , ndex_T ) ! salinity + CALL histwrite( nid_T, "sosstsst", it, tsn(:,:,1,jp_tem) , ndim_hT, ndex_hT ) ! sea surface temperature + CALL histwrite( nid_T, "sosaline", it, tsn(:,:,1,jp_sal) , ndim_hT, ndex_hT ) ! sea surface salinity + ENDIF + IF( .NOT.ln_linssh ) THEN + zw3d(:,:,:) = ( ( e3t_n(:,:,:) - e3t_0(:,:,:) ) / e3t_0(:,:,:) * 100 * tmask(:,:,:) ) ** 2 + CALL histwrite( nid_T, "vovvle3t", it, e3t_n (:,:,:) , ndim_T , ndex_T ) ! level thickness + CALL histwrite( nid_T, "vovvldep", it, gdept_n(:,:,:) , ndim_T , ndex_T ) ! t-point depth + CALL histwrite( nid_T, "vovvldef", it, zw3d , ndim_T , ndex_T ) ! level thickness deformation + ENDIF + CALL histwrite( nid_T, "sossheig", it, sshn , ndim_hT, ndex_hT ) ! sea surface height + CALL histwrite( nid_T, "sowaflup", it, ( emp-rnf ) , ndim_hT, ndex_hT ) ! upward water flux + CALL histwrite( nid_T, "sorunoff", it, rnf , ndim_hT, ndex_hT ) ! river runoffs + CALL histwrite( nid_T, "sosfldow", it, sfx , ndim_hT, ndex_hT ) ! downward salt flux + ! (includes virtual salt flux beneath ice + ! in linear free surface case) + IF( ln_linssh ) THEN + zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_tem) + CALL histwrite( nid_T, "sosst_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sst + zw2d(:,:) = emp (:,:) * tsn(:,:,1,jp_sal) + CALL histwrite( nid_T, "sosss_cd", it, zw2d, ndim_hT, ndex_hT ) ! c/d term on sss + ENDIF + CALL histwrite( nid_T, "sohefldo", it, qns + qsr , ndim_hT, ndex_hT ) ! total heat flux + CALL histwrite( nid_T, "soshfldo", it, qsr , ndim_hT, ndex_hT ) ! solar heat flux + CALL histwrite( nid_T, "somixhgt", it, hmld , ndim_hT, ndex_hT ) ! turbocline depth + CALL histwrite( nid_T, "somxl010", it, hmlp , ndim_hT, ndex_hT ) ! mixed layer depth + CALL histwrite( nid_T, "soicecov", it, fr_i , ndim_hT, ndex_hT ) ! ice fraction + CALL histwrite( nid_T, "sowindsp", it, wndm , ndim_hT, ndex_hT ) ! wind speed +! + IF( ln_icebergs ) THEN + ! + CALL histwrite( nid_T, "calving" , it, berg_grid%calving , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "calving_heat" , it, berg_grid%calving_hflx , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_floating_melt" , it, berg_grid%floating_melt, ndim_hT, ndex_hT ) + ! + CALL histwrite( nid_T, "berg_stored_ice" , it, berg_grid%stored_ice , ndim_bT, ndex_bT ) + ! + IF( ln_bergdia ) THEN + CALL histwrite( nid_T, "berg_melt" , it, berg_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_buoy_melt" , it, buoy_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_eros_melt" , it, eros_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_conv_melt" , it, conv_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_virtual_area" , it, virtual_area , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_src" , it, bits_src , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_melt" , it, bits_melt , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "bits_mass" , it, bits_mass , ndim_hT, ndex_hT ) + CALL histwrite( nid_T, "berg_mass" , it, berg_mass , ndim_hT, ndex_hT ) + ! + CALL histwrite( nid_T, "berg_real_calving" , it, real_calving , ndim_bT, ndex_bT ) + ENDIF + ENDIF + + IF( ln_ssr ) THEN + CALL histwrite( nid_T, "sohefldp", it, qrp , ndim_hT, ndex_hT ) ! heat flux damping + CALL histwrite( nid_T, "sowafldp", it, erp , ndim_hT, ndex_hT ) ! freshwater flux damping + zw2d(:,:) = erp(:,:) * tsn(:,:,1,jp_sal) * tmask(:,:,1) + CALL histwrite( nid_T, "sosafldp", it, zw2d , ndim_hT, ndex_hT ) ! salt flux damping + ENDIF +! zw2d(:,:) = FLOAT( nmln(:,:) ) * tmask(:,:,1) +! CALL histwrite( nid_T, "sobowlin", it, zw2d , ndim_hT, ndex_hT ) ! ??? + +#if defined key_diahth + CALL histwrite( nid_T, "sothedep", it, hth , ndim_hT, ndex_hT ) ! depth of the thermocline + CALL histwrite( nid_T, "so20chgt", it, hd20 , ndim_hT, ndex_hT ) ! depth of the 20 isotherm + CALL histwrite( nid_T, "so28chgt", it, hd28 , ndim_hT, ndex_hT ) ! depth of the 28 isotherm + CALL histwrite( nid_T, "sohtc300", it, htc3 , ndim_hT, ndex_hT ) ! first 300m heaat content +#endif + + CALL histwrite( nid_U, "vozocrtx", it, un , ndim_U , ndex_U ) ! i-current + CALL histwrite( nid_U, "sozotaux", it, utau , ndim_hU, ndex_hU ) ! i-wind stress + + CALL histwrite( nid_V, "vomecrty", it, vn , ndim_V , ndex_V ) ! j-current + CALL histwrite( nid_V, "sometauy", it, vtau , ndim_hV, ndex_hV ) ! j-wind stress + + IF( ln_zad_Aimp ) THEN + CALL histwrite( nid_W, "vovecrtz", it, wn + wi , ndim_T, ndex_T ) ! vert. current + ELSE + CALL histwrite( nid_W, "vovecrtz", it, wn , ndim_T, ndex_T ) ! vert. current + ENDIF + CALL histwrite( nid_W, "votkeavt", it, avt , ndim_T, ndex_T ) ! T vert. eddy diff. coef. + CALL histwrite( nid_W, "votkeavm", it, avm , ndim_T, ndex_T ) ! T vert. eddy visc. coef. + IF( ln_zdfddm ) THEN + CALL histwrite( nid_W, "voddmavs", it, avs , ndim_T, ndex_T ) ! S vert. eddy diff. coef. + ENDIF + + IF( ln_wave .AND. ln_sdw ) THEN + CALL histwrite( nid_U, "sdzocrtx", it, usd , ndim_U , ndex_U ) ! i-StokesDrift-current + CALL histwrite( nid_V, "sdmecrty", it, vsd , ndim_V , ndex_V ) ! j-StokesDrift-current + CALL histwrite( nid_W, "sdvecrtz", it, wsd , ndim_T , ndex_T ) ! StokesDrift vert. current + ENDIF + + ! 3. Close all files + ! --------------------------------------- + IF( kt == nitend ) THEN + CALL histclo( nid_T ) + CALL histclo( nid_U ) + CALL histclo( nid_V ) + CALL histclo( nid_W ) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('dia_wri') + ! + END SUBROUTINE dia_wri +#endif + + SUBROUTINE dia_wri_state( 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 + !!---------------------------------------------------------------------- + CHARACTER (len=* ), INTENT( in ) :: cdfile_name ! name of the file created + !! + INTEGER :: inum + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dia_wri_state : single instantaneous ocean state' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~ and forcing fields file created ' + IF(lwp) WRITE(numout,*) ' and named :', cdfile_name, '...nc' + +#if defined key_si3 + CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE., kdlev = jpl ) +#else + CALL iom_open( TRIM(cdfile_name), inum, ldwrt = .TRUE. ) +#endif + + CALL iom_rstput( 0, 0, inum, 'votemper', tsn(:,:,:,jp_tem) ) ! now temperature + CALL iom_rstput( 0, 0, inum, 'vosaline', tsn(:,:,:,jp_sal) ) ! now salinity + CALL iom_rstput( 0, 0, inum, 'sossheig', sshn ) ! sea surface height + CALL iom_rstput( 0, 0, inum, 'vozocrtx', un ) ! now i-velocity + CALL iom_rstput( 0, 0, inum, 'vomecrty', vn ) ! now j-velocity + IF( ln_zad_Aimp ) THEN + CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn + wi ) ! now k-velocity + ELSE + CALL iom_rstput( 0, 0, inum, 'vovecrtz', wn ) ! now k-velocity + ENDIF + 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 + CALL iom_rstput( 0, 0, inum, 'sowaflup', emp - rnf ) ! freshwater budget + CALL iom_rstput( 0, 0, inum, 'sohefldo', qsr + qns ) ! 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 + CALL iom_rstput( 0, 0, inum, 'vovvldep', gdept_n ) ! T-cell depth + CALL iom_rstput( 0, 0, inum, 'vovvle3t', e3t_n ) ! 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 defined key_si3 + IF( nn_ice == 2 ) THEN ! condition needed in case agrif + ice-model but no-ice in child grid + CALL ice_wri_state( inum ) + ENDIF +#endif + ! + CALL iom_close( inum ) + ! + END SUBROUTINE dia_wri_state + + !!====================================================================== +END MODULE diawri diff --git a/NEMO_4.0.4_surge/src/OCE/DIU/cool_skin.F90 b/NEMO_4.0.4_surge/src/OCE/DIU/cool_skin.F90 new file mode 100644 index 0000000..3500b80 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIU/cool_skin.F90 @@ -0,0 +1,146 @@ +MODULE cool_skin + !!====================================================================== + !! *** MODULE cool_skin *** + !! 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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, rdt) + !!---------------------------------------------------------------------- + !! *** 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(wp), INTENT(IN), DIMENSION(jpi,jpj) :: psrho ! Water density (kg/m^3) + REAL(wp), INTENT(IN) :: rdt ! 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 ) CALL ctl_stop("cool_skin.f90: diurnal flux processing only implemented for bulk forcing") + ! + DO jj = 1,jpj + DO ji = 1,jpi + ! + ! 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 cool_skin diff --git a/NEMO_4.0.4_surge/src/OCE/DIU/diurnal_bulk.F90 b/NEMO_4.0.4_surge/src/OCE/DIU/diurnal_bulk.F90 new file mode 100644 index 0000000..66ceffb --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIU/diurnal_bulk.F90 @@ -0,0 +1,267 @@ +MODULE diurnal_bulk + !!====================================================================== + !! *** MODULE diurnal_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 + LOGICAL, PUBLIC :: ln_diurnal_only + + ! 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 + + !!---------------------------------------------------------------------- +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 + REWIND( numnam_ref ) + READ ( numnam_ref, namdiu, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdiu in reference namelist' ) + REWIND( numnam_cfg ) + 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(wp), 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 = 1,jpj + DO ji = 1, jpi + 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(wp), 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 = 1, jpj + DO ji = 1, jpi + + ! 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 diurnal_bulk diff --git a/NEMO_4.0.4_surge/src/OCE/DIU/solfrac_mod.F90 b/NEMO_4.0.4_surge/src/OCE/DIU/solfrac_mod.F90 new file mode 100644 index 0000000..4df5c6e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIU/solfrac_mod.F90 @@ -0,0 +1,56 @@ +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 + +END MODULE solfrac_mod diff --git a/NEMO_4.0.4_surge/src/OCE/DIU/step_diu.F90 b/NEMO_4.0.4_surge/src/OCE/DIU/step_diu.F90 new file mode 100644 index 0000000..71a0a81 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DIU/step_diu.F90 @@ -0,0 +1,93 @@ +MODULE step_diu + !!====================================================================== + !! *** MODULE stp_diu *** + !! Time-stepping of diurnal cycle models + !!====================================================================== + !! History : 3.7 ! 2015-11 (J. While) Original code + + USE diurnal_bulk ! diurnal SST bulk routines (diurnal_sst_takaya routine) + USE cool_skin ! diurnal cool skin correction (diurnal_sst_coolskin routine) + 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$ + !! 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 + !! --------------------------------------------------------------------- + + 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 ) ! Sea Boundary Conditions + ENDIF + + ! Cool skin + IF( .NOT.ln_diurnal ) CALL ctl_stop( "stp_diurnal: ln_diurnal not set" ) + + IF( .NOT. ln_blk ) CALL ctl_stop( "stp_diurnal: diurnal flux processing only implemented for bulk forcing" ) + + CALL diurnal_sst_coolskin_step( qns, taum, rhop(:,:,1), rdt) + + 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), rdt) + + IF( ln_diurnal_only ) THEN + IF( ln_diaobs ) CALL dia_obs( kstp ) ! 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 ) ! 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/NEMO_4.0.4_surge/src/OCE/DOM/closea.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/closea.F90 new file mode 100644 index 0000000..e927ba7 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/closea.F90 @@ -0,0 +1,488 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_clo : read in masks which define closed seas and runoff areas + !! sbc_clo : Special handling of freshwater fluxes over closed seas + !! clo_rnf : set close sea outflows as river mouths (see sbcrnf) + !! clo_bat : set to zero a field over closed sea (see domzgr) + !!---------------------------------------------------------------------- + USE oce ! dynamics and tracers + USE dom_oce ! ocean space and time domain + USE phycst ! physical constants + USE sbc_oce ! ocean surface boundary conditions + USE iom ! I/O routines + ! + USE in_out_manager ! I/O manager + USE lib_fortran, ONLY: glob_sum + USE lbclnk ! lateral boundary condition - MPP exchanges + USE lib_mpp ! MPP library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_clo ! called by domain module + PUBLIC sbc_clo ! called by sbcmod module + PUBLIC clo_rnf ! called by sbcrnf module + PUBLIC clo_bat ! called in domzgr module + + LOGICAL, PUBLIC :: ln_closea !: T => keep closed seas (defined by closea_mask field) in the domain and apply + !: special treatment of freshwater fluxes. + !: F => suppress closed seas (defined by closea_mask field) from the bathymetry + !: at runtime. + !: If there is no closea_mask field in the domain_cfg file or we do not use + !: a domain_cfg file then this logical does nothing. + !: + LOGICAL, PUBLIC :: l_sbc_clo !: T => Closed seas defined, apply special treatment of freshwater fluxes. + !: F => No closed seas defined (closea_mask field not found). + LOGICAL, PUBLIC :: l_clo_rnf !: T => Some closed seas output freshwater (RNF or EMPMR) to specified runoff points. + INTEGER, PUBLIC :: jncs !: number of closed seas (inferred from closea_mask field) + INTEGER, PUBLIC :: jncsr !: number of closed seas rnf mappings (inferred from closea_mask_rnf field) + INTEGER, PUBLIC :: jncse !: number of closed seas empmr mappings (inferred from closea_mask_empmr field) + + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: closea_mask !: mask of integers defining closed seas + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: closea_mask_rnf !: mask of integers defining closed seas rnf mappings + INTEGER, PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: closea_mask_empmr !: mask of integers defining closed seas empmr mappings + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: surf !: closed sea surface areas + !: (and residual global surface area) + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: surfr !: closed sea target rnf surface areas + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:) :: surfe !: closed sea target empmr surface areas + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_clo() + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_clo *** + !! + !! ** Purpose : Closed sea domain initialization + !! + !! ** Method : if a closed sea is located only in a model grid point + !! just the thermodynamic processes are applied. + !! + !! ** Action : Read closea_mask* fields (if they exist) from domain_cfg file and infer + !! number of closed seas from closea_mask field. + !! closea_mask : integer values defining closed seas (or groups of closed seas) + !! closea_mask_rnf : integer values defining mappings from closed seas or groups of + !! closed seas to a runoff area for downwards flux only. + !! closea_mask_empmr : integer values defining mappings from closed seas or groups of + !! closed seas to a runoff area for net fluxes. + !! + !! Python code to generate the closea_masks* fields from the old-style indices + !! definitions is available at TOOLS/DOMAINcfg/make_closea_masks.py + !!---------------------------------------------------------------------- + INTEGER :: inum ! input file identifier + INTEGER :: ierr ! error code + INTEGER :: id ! netcdf variable ID + + REAL(wp), DIMENSION(jpi,jpj) :: zdata_in ! temporary real array for input + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'dom_clo : read in masks to define closed seas ' + IF(lwp) WRITE(numout,*)'~~~~~~~' + ! + ! read the closed seas masks (if they exist) from domain_cfg file (if it exists) + ! ------------------------------------------------------------------------------ + ! + IF( ln_read_cfg) THEN + ! + CALL iom_open( cn_domcfg, inum ) + ! + id = iom_varid(inum, 'closea_mask', ldstop = .false.) + IF( id > 0 ) THEN + l_sbc_clo = .true. + ALLOCATE( closea_mask(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'dom_clo: failed to allocate closea_mask array') + zdata_in(:,:) = 0.0 + CALL iom_get ( inum, jpdom_data, 'closea_mask', zdata_in ) + closea_mask(:,:) = NINT(zdata_in(:,:)) * tmask(:,:,1) + ! number of closed seas = global maximum value in closea_mask field + jncs = maxval(closea_mask(:,:)) + CALL mpp_max('closea', jncs) + IF( jncs > 0 ) THEN + IF( lwp ) WRITE(numout,*) 'Number of closed seas : ',jncs + ELSE + CALL ctl_stop( 'Problem with closea_mask field in domain_cfg file. Has no values > 0 so no closed seas defined.') + ENDIF + ELSE + IF( lwp ) WRITE(numout,*) + IF( lwp ) WRITE(numout,*) ' ==>>> closea_mask field not found in domain_cfg file.' + IF( lwp ) WRITE(numout,*) ' No closed seas defined.' + IF( lwp ) WRITE(numout,*) + l_sbc_clo = .false. + jncs = 0 + ENDIF + + l_clo_rnf = .false. + + IF( l_sbc_clo ) THEN ! No point reading in closea_mask_rnf or closea_mask_empmr fields if no closed seas defined. + + id = iom_varid(inum, 'closea_mask_rnf', ldstop = .false.) + IF( id > 0 ) THEN + l_clo_rnf = .true. + ALLOCATE( closea_mask_rnf(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'dom_clo: failed to allocate closea_mask_rnf array') + CALL iom_get ( inum, jpdom_data, 'closea_mask_rnf', zdata_in ) + closea_mask_rnf(:,:) = NINT(zdata_in(:,:)) * tmask(:,:,1) + ! number of closed seas rnf mappings = global maximum in closea_mask_rnf field + jncsr = maxval(closea_mask_rnf(:,:)) + CALL mpp_max('closea', jncsr) + IF( jncsr > 0 ) THEN + IF( lwp ) WRITE(numout,*) 'Number of closed seas rnf mappings : ',jncsr + ELSE + CALL ctl_stop( 'Problem with closea_mask_rnf field in domain_cfg file. Has no values > 0 so no closed seas rnf mappings defined.') + ENDIF + ELSE + IF( lwp ) WRITE(numout,*) 'closea_mask_rnf field not found in domain_cfg file. No closed seas rnf mappings defined.' + jncsr = 0 + ENDIF + + id = iom_varid(inum, 'closea_mask_empmr', ldstop = .false.) + IF( id > 0 ) THEN + l_clo_rnf = .true. + ALLOCATE( closea_mask_empmr(jpi,jpj) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'dom_clo: failed to allocate closea_mask_empmr array') + CALL iom_get ( inum, jpdom_data, 'closea_mask_empmr', zdata_in ) + closea_mask_empmr(:,:) = NINT(zdata_in(:,:)) * tmask(:,:,1) + ! number of closed seas empmr mappings = global maximum value in closea_mask_empmr field + jncse = maxval(closea_mask_empmr(:,:)) + CALL mpp_max('closea', jncse) + IF( jncse > 0 ) THEN + IF( lwp ) WRITE(numout,*) 'Number of closed seas empmr mappings : ',jncse + ELSE + CALL ctl_stop( 'Problem with closea_mask_empmr field in domain_cfg file. Has no values > 0 so no closed seas empmr mappings defined.') + ENDIF + ELSE + IF( lwp ) WRITE(numout,*) 'closea_mask_empmr field not found in domain_cfg file. No closed seas empmr mappings defined.' + jncse = 0 + ENDIF + + ENDIF ! l_sbc_clo + ! + CALL iom_close( inum ) + ! + ELSE ! ln_read_cfg = .false. so no domain_cfg file + IF( lwp ) WRITE(numout,*) 'No domain_cfg file so no closed seas defined.' + l_sbc_clo = .false. + l_clo_rnf = .false. + ENDIF + ! + END SUBROUTINE dom_clo + + + 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 : emp updated surface freshwater fluxes and associated heat content at kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean model time step + ! + INTEGER :: ierr + INTEGER :: jc, jcr, jce ! dummy loop indices + REAL(wp), PARAMETER :: rsmall = 1.e-20_wp ! Closed sea correction epsilon + REAL(wp) :: zfwf_total, zcoef, zcoef1 ! + REAL(wp), DIMENSION(jncs) :: zfwf !: + REAL(wp), DIMENSION(jncsr+1) :: zfwfr !: freshwater fluxes over closed seas + REAL(wp), DIMENSION(jncse+1) :: zfwfe !: + REAL(wp), DIMENSION(jpi,jpj) :: ztmp2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('sbc_clo') + ! + ! !------------------! + IF( kt == nit000 ) THEN ! Initialisation ! + ! !------------------! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)'sbc_clo : closed seas ' + IF(lwp) WRITE(numout,*)'~~~~~~~' + + ALLOCATE( surf(jncs+1) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surf array') + surf(:) = 0.e0_wp + ! + ! jncsr can be zero so add 1 to avoid allocating zero-length array + ALLOCATE( surfr(jncsr+1) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surfr array') + surfr(:) = 0.e0_wp + ! + ! jncse can be zero so add 1 to avoid allocating zero-length array + ALLOCATE( surfe(jncse+1) , STAT=ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'sbc_clo: failed to allocate surfe array') + surfe(:) = 0.e0_wp + ! + surf(jncs+1) = glob_sum( 'closea', e1e2t(:,:) ) ! surface of the global ocean + ! + ! ! surface areas of closed seas + DO jc = 1, jncs + ztmp2d(:,:) = 0.e0_wp + WHERE( closea_mask(:,:) == jc ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:) + surf(jc) = glob_sum( 'closea', ztmp2d(:,:) ) + END DO + ! + ! jncs+1 : surface area of global ocean, closed seas excluded + surf(jncs+1) = surf(jncs+1) - SUM(surf(1:jncs)) + ! + ! ! surface areas of rnf target areas + IF( jncsr > 0 ) THEN + DO jcr = 1, jncsr + ztmp2d(:,:) = 0.e0_wp + WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) == 0 ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:) + surfr(jcr) = glob_sum( 'closea', ztmp2d(:,:) ) + END DO + ENDIF + ! + ! ! surface areas of empmr target areas + IF( jncse > 0 ) THEN + DO jce = 1, jncse + ztmp2d(:,:) = 0.e0_wp + WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) == 0 ) ztmp2d(:,:) = e1e2t(:,:) * tmask_i(:,:) + surfe(jce) = glob_sum( 'closea', ztmp2d(:,:) ) + END DO + ENDIF + ! + IF(lwp) WRITE(numout,*)' Closed sea surface areas (km2)' + DO jc = 1, jncs + IF(lwp) WRITE(numout,FMT='(1I3,5X,ES12.2)') jc, surf(jc) * 1.0e-6 + END DO + IF(lwp) WRITE(numout,FMT='(A,ES12.2)') 'Global surface area excluding closed seas (km2): ', surf(jncs+1) * 1.0e-6 + ! + IF(jncsr > 0) THEN + IF(lwp) WRITE(numout,*)' Closed sea target rnf surface areas (km2)' + DO jcr = 1, jncsr + IF(lwp) WRITE(numout,FMT='(1I3,5X,ES12.2)') jcr, surfr(jcr) * 1.0e-6 + END DO + ENDIF + ! + IF(jncse > 0) THEN + IF(lwp) WRITE(numout,*)' Closed sea target empmr surface areas (km2)' + DO jce = 1, jncse + IF(lwp) WRITE(numout,FMT='(1I3,5X,ES12.2)') jce, surfe(jce) * 1.0e-6 + END DO + ENDIF + ENDIF + ! + ! !--------------------! + ! ! update emp ! + ! !--------------------! + + zfwf_total = 0._wp + + ! + ! 1. Work out total freshwater fluxes over closed seas from EMP - RNF. + ! + zfwf(:) = 0.e0_wp + DO jc = 1, jncs + ztmp2d(:,:) = 0.e0_wp + WHERE( closea_mask(:,:) == jc ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:) + zfwf(jc) = glob_sum( 'closea', ztmp2d(:,:) ) + END DO + zfwf_total = SUM(zfwf) + + zfwfr(:) = 0.e0_wp + IF( jncsr > 0 ) THEN + ! + ! 2. Work out total FW fluxes over rnf source areas and add to rnf target areas. + ! Where zfwf is negative add flux at specified runoff points and subtract from fluxes for global redistribution. + ! Where positive leave in global redistribution total. + ! + DO jcr = 1, jncsr + ! + ztmp2d(:,:) = 0.e0_wp + WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) > 0 ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:) + zfwfr(jcr) = glob_sum( 'closea', ztmp2d(:,:) ) + ! + ! The following if avoids the redistribution of the round off + IF ( ABS(zfwfr(jcr) / surf(jncs+1) ) > rsmall) THEN + ! + ! Add residuals to target runoff points if negative and subtract from total to be added globally + IF( zfwfr(jcr) < 0.0 ) THEN + zfwf_total = zfwf_total - zfwfr(jcr) + zcoef = zfwfr(jcr) / surfr(jcr) + zcoef1 = rcp * zcoef + WHERE( closea_mask_rnf(:,:) == jcr .and. closea_mask(:,:) == 0.0) + emp(:,:) = emp(:,:) + zcoef + qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:) + ENDWHERE + ENDIF + ! + ENDIF + END DO + ENDIF ! jncsr > 0 + ! + zfwfe(:) = 0.e0_wp + IF( jncse > 0 ) THEN + ! + ! 3. Work out total fluxes over empmr source areas and add to empmr target areas. + ! + DO jce = 1, jncse + ! + ztmp2d(:,:) = 0.e0_wp + WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) > 0 ) ztmp2d(:,:) = e1e2t(:,:) * ( emp(:,:)-rnf(:,:) ) * tmask_i(:,:) + zfwfe(jce) = glob_sum( 'closea', ztmp2d(:,:) ) + ! + ! The following if avoids the redistribution of the round off + IF ( ABS( zfwfe(jce) / surf(jncs+1) ) > rsmall ) THEN + ! + ! Add residuals to runoff points and subtract from total to be added globally + zfwf_total = zfwf_total - zfwfe(jce) + zcoef = zfwfe(jce) / surfe(jce) + zcoef1 = rcp * zcoef + WHERE( closea_mask_empmr(:,:) == jce .and. closea_mask(:,:) == 0.0) + emp(:,:) = emp(:,:) + zcoef + qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:) + ENDWHERE + ! + ENDIF + END DO + ENDIF ! jncse > 0 + + ! + ! 4. Spread residual flux over global ocean. + ! + ! The following if avoids the redistribution of the round off + IF ( ABS(zfwf_total / surf(jncs+1) ) > rsmall) THEN + zcoef = zfwf_total / surf(jncs+1) + zcoef1 = rcp * zcoef + WHERE( closea_mask(:,:) == 0 ) + emp(:,:) = emp(:,:) + zcoef + qns(:,:) = qns(:,:) - zcoef1 * sst_m(:,:) + ENDWHERE + ENDIF + + ! + ! 5. Subtract area means from emp (and qns) over closed seas to give zero mean FW flux over each sea. + ! + DO jc = 1, jncs + ! The following if avoids the redistribution of the round off + IF ( ABS(zfwf(jc) / surf(jncs+1) ) > rsmall) THEN + ! + ! Subtract residuals from fluxes over closed sea + zcoef = zfwf(jc) / surf(jc) + zcoef1 = rcp * zcoef + WHERE( closea_mask(:,:) == jc ) + emp(:,:) = emp(:,:) - zcoef + qns(:,:) = qns(:,:) + zcoef1 * sst_m(:,:) + ENDWHERE + ! + ENDIF + END DO + ! + emp (:,:) = emp (:,:) * tmask(:,:,1) + ! + CALL lbc_lnk( 'closea', emp , 'T', 1._wp ) + ! + END SUBROUTINE sbc_clo + + SUBROUTINE clo_rnf( p_rnfmsk ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_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) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: p_rnfmsk ! river runoff mask (rnfmsk array) + !!---------------------------------------------------------------------- + ! + IF( jncsr > 0 ) THEN + WHERE( closea_mask_rnf(:,:) > 0 .and. closea_mask(:,:) == 0 ) + p_rnfmsk(:,:) = MAX( p_rnfmsk(:,:), 1.0_wp ) + ENDWHERE + ENDIF + ! + IF( jncse > 0 ) THEN + WHERE( closea_mask_empmr(:,:) > 0 .and. closea_mask(:,:) == 0 ) + p_rnfmsk(:,:) = MAX( p_rnfmsk(:,:), 1.0_wp ) + ENDWHERE + ENDIF + ! + END SUBROUTINE clo_rnf + + + SUBROUTINE clo_bat( k_top, k_bot ) + !!--------------------------------------------------------------------- + !! *** ROUTINE clo_bat *** + !! + !! ** Purpose : Suppress closed sea from the domain + !! + !! ** Method : Read in closea_mask field (if it exists) from domain_cfg file. + !! 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 + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(inout) :: k_top, k_bot ! ocean first and last level indices + INTEGER :: inum, id + INTEGER, DIMENSION(jpi,jpj) :: closea_mask ! closea_mask field + REAL(wp), DIMENSION(jpi,jpj) :: zdata_in ! temporary real array for input + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'clo_bat : suppression of closed seas' + WRITE(numout,*) '~~~~~~~' + ENDIF + ! + IF( ln_read_cfg ) THEN + ! + CALL iom_open( cn_domcfg, inum ) + ! + id = iom_varid(inum, 'closea_mask', ldstop = .false.) + IF( id > 0 ) THEN + IF( lwp ) WRITE(numout,*) 'Suppressing closed seas in bathymetry based on closea_mask field,' + CALL iom_get ( inum, jpdom_data, 'closea_mask', zdata_in ) + closea_mask(:,:) = NINT(zdata_in(:,:)) + WHERE( closea_mask(:,:) > 0 ) + k_top(:,:) = 0 + k_bot(:,:) = 0 + ENDWHERE + ELSE + IF( lwp ) WRITE(numout,*) 'No closea_mask field found in domain_cfg file. No suppression of closed seas.' + ENDIF + ! + CALL iom_close(inum) + ! + ELSE + IF( lwp ) WRITE(numout,*) 'No domain_cfg file => no suppression of closed seas.' + ENDIF + ! + ! Initialise l_sbc_clo and l_clo_rnf for this case (ln_closea=.false.) + l_sbc_clo = .false. + l_clo_rnf = .false. + ! + END SUBROUTINE clo_bat + + !!====================================================================== +END MODULE closea + diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/daymod.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/daymod.F90 new file mode 100644 index 0000000..4de9649 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/daymod.F90 @@ -0,0 +1,421 @@ +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, rdt ) == 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$ + !! 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 year nyear + !! - nday : current day of the month nmonth + !! - nday_year : current day of the year nyear + !! - nsec_year : current time step counted in second since 00h jan 1st of the current year + !! - nsec_month : current time step counted in second since 00h 1st day of the current month + !! - nsec_day : current time step counted in second since 00h of the current day + !! - nsec1jan000 : second since Jan. 1st 00h of nit000 year and Jan. 1st 00h of the current year + !! - nmonth_len, nyear_len, nmonth_half, nmonth_end through day_mth + !!---------------------------------------------------------------------- + INTEGER :: inbday, idweek ! local integers + REAL(wp) :: zjul ! local scalar + !!---------------------------------------------------------------------- + ! + ! max number of seconds between each restart + IF( REAL( nitend - nit000 + 1 ) * rdt > 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( rdt ) + ndt05 = NINT( 0.5 * rdt ) + + IF( .NOT. l_offline ) 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 ) + + CALL ymds2ju( nyear, nmonth, nday, nhour*3600._wp+nminute*60._wp, fjulday ) + IF( ABS(fjulday - REAL(NINT(fjulday),wp)) < 0.1 / rday ) fjulday = REAL(NINT(fjulday),wp) ! avoid truncation error + IF( nhour*3600 + nminute*60 - 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, 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 + idweek = MOD(inbday, 7) ! compute nb day between last monday and current day + IF (idweek .lt. 0) idweek=idweek+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 (nhour*3600+nminute*60-ndt05 .gt. 0) THEN + ! 1 timestep before current middle of first time step is still the same day + nsec_year = (nday_year-1) * nsecd + nhour*3600+nminute*60 - ndt05 + nsec_month = (nday-1) * nsecd + nhour*3600+nminute*60 - ndt05 + ELSE + ! 1 time step before the middle of the first time step is the previous day + nsec_year = nday_year * nsecd + nhour*3600+nminute*60 - ndt05 + nsec_month = nday * nsecd + nhour*3600+nminute*60 - ndt05 + ENDIF + nsec_week = idweek * nsecd + nhour*3600+nminute*60 - ndt05 + nsec_day = nhour*3600+nminute*60 - ndt05 + IF( nsec_day .lt. 0 ) nsec_day = nsec_day + nsecd + IF( nsec_week .lt. 0 ) nsec_week = nsec_week + 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_week:', nsec_week, ' & + & nsec_month:', nsec_month , ' nsec_year:' , nsec_year + + ! 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 ) + ! + IF( lwxios ) THEN +! define variables in restart file when writing with XIOS + CALL iom_set_rstw_var_active('kt') + CALL iom_set_rstw_var_active('ndastp') + CALL iom_set_rstw_var_active('adatrj') + CALL iom_set_rstw_var_active('ntime') + ENDIF + + END SUBROUTINE day_init + + + SUBROUTINE day_mth + !!---------------------------------------------------------------------- + !! *** ROUTINE day_init *** + !! + !! ** Purpose : calendar values related to the months + !! + !! ** Action : - nmonth_len : length in days of the months of the current year + !! - nyear_len : length in days of the previous/current year + !! - nmonth_half : second since the beginning of the year and the halft of the months + !! - nmonth_end : second since the beginning of the year and the end of the months + !!---------------------------------------------------------------------- + INTEGER :: jm ! dummy loop indice + !!---------------------------------------------------------------------- + + ! length of the month of the current year (from nleapy, read in namelist) + IF ( nleapy < 2 ) THEN + nmonth_len(:) = (/ 31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31 /) + nyear_len(:) = 365 + IF ( nleapy == 1 ) THEN ! we are using calandar with leap years + IF ( MOD(nyear-1, 4) == 0 .AND. ( MOD(nyear-1, 400) == 0 .OR. MOD(nyear-1, 100) /= 0 ) ) THEN + nyear_len(0) = 366 + ENDIF + IF ( MOD(nyear , 4) == 0 .AND. ( MOD(nyear , 400) == 0 .OR. MOD(nyear , 100) /= 0 ) ) THEN + nmonth_len(2) = 29 + nyear_len(1) = 366 + ENDIF + IF ( MOD(nyear+1, 4) == 0 .AND. ( MOD(nyear+1, 400) == 0 .OR. MOD(nyear+1, 100) /= 0 ) ) THEN + nyear_len(2) = 366 + ENDIF + ENDIF + ELSE + nmonth_len(:) = nleapy ! all months with nleapy days per year + nyear_len(:) = 12 * nleapy + ENDIF + + ! half month in second since the begining of the year: + ! time since Jan 1st 0 1 2 ... 11 12 13 + ! ---------*--|--*--|--*--| ... |--*--|--*--|--*--|-------------------------------------- + ! <---> <---> <---> ... <---> <---> <---> + ! month number 0 1 2 ... 11 12 13 + ! + ! nmonth_half(jm) = rday * REAL( 0.5 * nmonth_len(jm) + SUM(nmonth_len(1:jm-1)) ) + nmonth_half(0) = - nsecd05 * nmonth_len(0) + DO jm = 1, 13 + nmonth_half(jm) = nmonth_half(jm-1) + nsecd05 * ( nmonth_len(jm-1) + nmonth_len(jm) ) + END DO + + nmonth_end(0) = 0 + DO jm = 1, 13 + nmonth_end(jm) = nmonth_end(jm-1) + nsecd * nmonth_len(jm) + END DO + ! + END SUBROUTINE + + + 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(wp) :: 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_week = nsec_week + ndt + nsec_day = nsec_day + ndt + adatrj = adatrj + rdt / rday + fjulday = fjulday + rdt / 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, 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_week = ', nsec_week + ENDIF + + IF( nsec_week > 7*nsecd ) nsec_week = ndt05 ! New week + + IF(ln_ctl) 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)*rdt. + !! 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(wp) :: zkt, zndastp, zdayfrac, ksecs, ktime + INTEGER :: ihour, iminute + !!---------------------------------------------------------------------- + + IF( TRIM(cdrw) == 'READ' ) THEN + + IF( iom_varid( numror, 'kt', ldstop = .FALSE. ) > 0 ) THEN + ! Get Calendar informations + CALL iom_get( numror, 'kt', zkt, ldxios = lrxios ) ! 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, ldxios = lrxios ) + ndastp = NINT( zndastp ) + CALL iom_get( numror, 'adatrj', adatrj , ldxios = lrxios ) + CALL iom_get( numror, 'ntime' , ktime , ldxios = lrxios ) + nn_time0=INT(ktime) + ! calculate start time in hours and minutes + zdayfrac=adatrj-INT(adatrj) + ksecs = NINT(zdayfrac*86400) ! Nearest second to catch rounding errors in adatrj + ihour = INT(ksecs/3600) + iminute = ksecs/60-ihour*60 + + ! Add to nn_time0 + nhour = nn_time0 / 100 + nminute = ( nn_time0 - nhour * 100 ) + nminute=nminute+iminute + + IF( nminute >= 60 ) THEN + nminute=nminute-60 + nhour=nhour+1 + ENDIF + nhour=nhour+ihour + IF( nhour >= 24 ) THEN + nhour=nhour-24 + adatrj=adatrj+1 + ENDIF + nn_time0 = nhour * 100 + nminute + adatrj = INT(adatrj) ! 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 ) + IF( nhour*3600+nminute*60-ndt05 .lt. 0 ) ndastp=ndastp-1 ! Start hour is specified in the namelist (default 0) + adatrj = ( REAL( nit000-1, wp ) * rdt ) / 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 ) + IF( nhour*3600+nminute*60-ndt05 .lt. 0 ) ndastp=ndastp-1 ! Start hour is specified in the namelist (default 0) + adatrj = ( REAL( nit000-1, wp ) * rdt ) / 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 + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'kt' , REAL( kt , wp) , ldxios = lwxios ) ! time-step + CALL iom_rstput( kt, nitrst, numrow, 'ndastp' , REAL( ndastp, wp) , ldxios = lwxios ) ! date + CALL iom_rstput( kt, nitrst, numrow, 'adatrj' , adatrj , ldxios = lwxios ) ! number of elapsed days since + ! ! the begining of the run [s] + CALL iom_rstput( kt, nitrst, numrow, 'ntime' , REAL( nn_time0, wp), ldxios = lwxios ) ! time + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + END SUBROUTINE day_rst + + !!====================================================================== +END MODULE daymod diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/depth_e3.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/depth_e3.F90 new file mode 100644 index 0000000..377e07c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/depth_e3.F90 @@ -0,0 +1,164 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) :: pe3t_3d , pe3w_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/NEMO_4.0.4_surge/src/OCE/DOM/dom_oce.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/dom_oce.F90 new file mode 100644 index 0000000..4f63f96 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/dom_oce.F90 @@ -0,0 +1,303 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! Agrif_Root : 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_isfhmin !: threshold to discriminate grounded ice to floating ice + REAL(wp), PUBLIC :: rn_rdt !: time step for the dynamics and tracer + REAL(wp), PUBLIC :: rn_atfp !: asselin time filter parameter + INTEGER , PUBLIC :: nn_euler !: =0 start with forward time step or not (=1) + LOGICAL , PUBLIC :: ln_iscpl !: coupling with ice sheet + LOGICAL , PUBLIC :: ln_crs !: Apply grid coarsening to dynamical model output or online passive tracers + LOGICAL , PUBLIC :: ln_2d ! Default False. If True run in 2D barotropic mode (no tracer processes or vertical diffusion) + + !! 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_baro !: Number of barotropic iterations during one baroclinic step (rdt) + 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 + + + ! !! old non-DOCTOR names still used in the model + REAL(wp), PUBLIC :: atfp !: asselin time filter parameter + REAL(wp), PUBLIC :: rdt !: time step for the dynamics and tracer + + ! !!! associated variables + INTEGER , PUBLIC :: neuler !: restart euler forward option (0=Euler) + REAL(wp), PUBLIC :: r2dt !: = 2*rdt except at nit000 (=rdt) if neuler=0 + + !!---------------------------------------------------------------------- + !! space domain parameters + !!---------------------------------------------------------------------- + INTEGER, PUBLIC :: jperio !: Global domain lateral boundary type (between 0 and 7) + ! ! = 0 closed ; = 1 cyclic East-West + ! ! = 2 cyclic North-South ; = 3 North fold T-point pivot + ! ! = 4 cyclic East-West AND North fold T-point pivot + ! ! = 5 North fold F-point pivot + ! ! = 6 cyclic East-West AND North fold F-point pivot + ! ! = 7 bi-cyclic East-West AND North-South + LOGICAL, PUBLIC :: l_Iperio, l_Jperio ! should we explicitely take care I/J periodicity + LOGICAL, PUBLIC :: l_Westedge, l_Eastedge, l_Northedge, l_Southedge ! flag to detect global domain edges + ! on local domain (needed for AGRIF) + + ! ! domain MPP decomposition parameters + INTEGER , PUBLIC :: nimpp, njmpp !: i- & j-indexes for mpp-subdomain left bottom + INTEGER , PUBLIC :: nreci, nrecj !: overlap region in i and j + INTEGER , PUBLIC :: nproc !: number for local processor + INTEGER , PUBLIC :: narea !: number for local area + INTEGER , PUBLIC :: nbondi, nbondj !: mark of i- and j-direction local boundaries + INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy(:) !: mark i-direction local boundaries for BDY open boundaries + INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy(:) !: mark j-direction local boundaries for BDY open boundaries + INTEGER, ALLOCATABLE, PUBLIC :: nbondi_bdy_b(:) !: mark i-direction of neighbours local boundaries for BDY open boundaries + INTEGER, ALLOCATABLE, PUBLIC :: nbondj_bdy_b(:) !: mark j-direction of neighbours local boundaries for BDY open boundaries + + INTEGER, PUBLIC :: npolj !: north fold mark (0, 3 or 4) + INTEGER, PUBLIC :: nlci, nldi, nlei !: i-dimensions of the local subdomain and its first and last indoor indices + INTEGER, PUBLIC :: nlcj, nldj, nlej !: i-dimensions of the local subdomain and its first and last indoor indices + INTEGER, PUBLIC :: noea, nowe !: index of the local neighboring processors in + INTEGER, PUBLIC :: noso, nono !: east, west, south and north directions + INTEGER, PUBLIC :: nidom !: ??? + + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mig !: local ==> global domain i-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mjg !: local ==> global domain j-index + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mi0, mi1 !: global ==> local domain i-index (mi0=1 and mi1=0 if the global index + ! ! is not in the local domain) + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: mj0, mj1 !: global ==> local domain j-index (mj0=1 and mj1=0 if the global index + ! ! is not in the local domain) + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nimppt, njmppt !: i-, j-indexes for each processor + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: ibonit, ibonjt !: i-, j- processor neighbour existence + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nlcit , nlcjt !: dimensions of every subdomain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nldit , nldjt !: first, last indoor index for each i-domain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nleit , nlejt !: first, last indoor index for each j-domain + INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfiimpp, nfipproc, nfilcit + + !!---------------------------------------------------------------------- + !! 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(:,:) :: e1t , e2t , r1_e1t, r1_e2t !: t-point horizontal scale factors [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1u , e2u , r1_e1u, r1_e2u !: horizontal scale factors at u-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1v , e2v , r1_e1v, r1_e2v !: horizontal scale factors at v-point [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, TARGET, DIMENSION(:,:) :: e1f , e2f , r1_e1f, r1_e2f !: horizontal scale factors at f-point [m] + ! + REAL(wp), 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 :: 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 + ! ! ref. ! before ! now ! after ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3t_0 , e3t_b , e3t_n , e3t_a !: t- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3u_0 , e3u_b , e3u_n , e3u_a !: u- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3v_0 , e3v_b , e3v_n , e3v_a !: v- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3f_0 , e3f_n !: f- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3w_0 , e3w_b , e3w_n !: w- vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3uw_0 , e3uw_b , e3uw_n !: uw-vert. scale factor [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: e3vw_0 , e3vw_b , e3vw_n !: vw-vert. scale factor [m] + + ! ! ref. ! before ! now ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdept_0 , gdept_b , gdept_n !: t- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gdepw_0 , gdepw_b , gdepw_n !: w- depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: gde3w_0 , gde3w_n !: w- depth (sum of e3w) [m] + + ! ! ref. ! before ! now ! after ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ht_0 , ht_n !: t-depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hu_0 , hu_b , hu_n , hu_a !: u-depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hv_0 , hv_b , hv_n , hv_a !: v-depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hu_b , r1_hu_n , r1_hu_a !: inverse of u-depth [1/m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hv_b , r1_hv_n , r1_hv_a !: inverse of v-depth [1/m] + + 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) + + + !!---------------------------------------------------------------------- + !! 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-, V-, F-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 !: bottom last wet T-, U- and V-level + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_i !: interior domain T-point mask + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: tmask_h !: internal domain T-point mask (Figure 8.5 NEMO book) + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfdep !: top first ocean level (ISF) + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: mikt, miku, mikv, mikf !: top first wet T-, U-, V-, F-level (ISF) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfdep !: Iceshelf draft (ISF) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ssmask, ssumask, ssvmask !: 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- and F-pts + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:), TARGET :: wmask, wumask, wvmask !: land/ocean mask at WT-, WU- and WV-pts + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4) + + !!---------------------------------------------------------------------- + !! 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 !: current time step counted in second since 00h jan 1st of the current year + INTEGER , PUBLIC :: nsec_month !: current time step counted in second since 00h 1st day of the current month + INTEGER , PUBLIC :: nsec_week !: current time step counted in second since 00h of last monday + INTEGER , PUBLIC :: nsec_day !: current time step counted in second since 00h of the current day + REAL(wp), PUBLIC :: fjulday !: current julian day + REAL(wp), 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(0:13) :: nmonth_len !: length in days of the months of the current year + INTEGER , PUBLIC, DIMENSION(0:13) :: nmonth_half !: second since Jan 1st 0h of the current year and the half of the months + INTEGER , PUBLIC, DIMENSION(0:13) :: nmonth_end !: second since Jan 1st 0h of the current year and the end of the months + INTEGER , PUBLIC :: nsec1jan000 !: second since Jan 1st 0h of nit000 year and Jan 1st 0h the current year + + !!---------------------------------------------------------------------- + !! agrif domain + !!---------------------------------------------------------------------- +#if defined key_agrif + LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .TRUE. !: agrif flag +#else + LOGICAL, PUBLIC, PARAMETER :: lk_agrif = .FALSE. !: agrif flag +#endif + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if ! defined key_agrif + !!---------------------------------------------------------------------- + !! NOT 'key_agrif' dummy function No AGRIF zoom + !!---------------------------------------------------------------------- + LOGICAL FUNCTION Agrif_Root() + Agrif_Root = .TRUE. + END FUNCTION Agrif_Root + + CHARACTER(len=3) FUNCTION Agrif_CFixed() + Agrif_CFixed = '0' + END FUNCTION Agrif_CFixed + + INTEGER FUNCTION Agrif_Fixed() + Agrif_Fixed = 0 + END FUNCTION Agrif_Fixed +#endif + + INTEGER FUNCTION dom_oce_alloc() + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(12) :: ierr + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( mig(jpi), mjg(jpj), STAT=ierr(1) ) + ! + ALLOCATE( mi0(jpiglo) , mi1 (jpiglo), mj0(jpjglo) , mj1 (jpjglo) , & + & tpol(jpiglo) , fpol(jpiglo) , STAT=ierr(2) ) + ! + 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(3) ) + ! + ALLOCATE( gdept_0(jpi,jpj,jpk) , gdepw_0(jpi,jpj,jpk) , gde3w_0(jpi,jpj,jpk) , & + & gdept_b(jpi,jpj,jpk) , gdepw_b(jpi,jpj,jpk) , & + & gdept_n(jpi,jpj,jpk) , gdepw_n(jpi,jpj,jpk) , gde3w_n(jpi,jpj,jpk) , STAT=ierr(4) ) + ! + 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) , & + & e3t_b(jpi,jpj,jpk) , e3u_b(jpi,jpj,jpk) , e3v_b(jpi,jpj,jpk) , e3w_b(jpi,jpj,jpk) , & + & e3t_n(jpi,jpj,jpk) , e3u_n(jpi,jpj,jpk) , e3v_n(jpi,jpj,jpk) , e3f_n(jpi,jpj,jpk) , e3w_n(jpi,jpj,jpk) , & + & e3t_a(jpi,jpj,jpk) , e3u_a(jpi,jpj,jpk) , e3v_a(jpi,jpj,jpk) , & + ! ! + & e3uw_0(jpi,jpj,jpk) , e3vw_0(jpi,jpj,jpk) , & + & e3uw_b(jpi,jpj,jpk) , e3vw_b(jpi,jpj,jpk) , & + & e3uw_n(jpi,jpj,jpk) , e3vw_n(jpi,jpj,jpk) , STAT=ierr(5) ) + ! + ALLOCATE( ht_0(jpi,jpj) , hu_0(jpi,jpj) , hv_0(jpi,jpj) , & + & hu_b(jpi,jpj) , hv_b(jpi,jpj) , r1_hu_b(jpi,jpj) , r1_hv_b(jpi,jpj) , & + & ht_n(jpi,jpj) , hu_n(jpi,jpj) , hv_n(jpi,jpj) , r1_hu_n(jpi,jpj) , r1_hv_n(jpi,jpj) , & + & hu_a(jpi,jpj) , hv_a(jpi,jpj) , r1_hu_a(jpi,jpj) , r1_hv_a(jpi,jpj) , STAT=ierr(6) ) + ! + ! + ALLOCATE( gdept_1d(jpk) , gdepw_1d(jpk) , e3t_1d(jpk) , e3w_1d(jpk) , STAT=ierr(7) ) + ! + ALLOCATE( tmask_i(jpi,jpj) , tmask_h(jpi,jpj) , & + & ssmask (jpi,jpj) , ssumask(jpi,jpj) , ssvmask(jpi,jpj) , & + & mbkt (jpi,jpj) , mbku (jpi,jpj) , mbkv (jpi,jpj) , STAT=ierr(9) ) + ! + ALLOCATE( misfdep(jpi,jpj) , mikt(jpi,jpj) , miku(jpi,jpj) , & + & risfdep(jpi,jpj) , mikv(jpi,jpj) , mikf(jpi,jpj) , STAT=ierr(10) ) + ! + ALLOCATE( tmask(jpi,jpj,jpk) , umask(jpi,jpj,jpk) , & + & vmask(jpi,jpj,jpk) , fmask(jpi,jpj,jpk) , STAT=ierr(11) ) + ! + ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) + ! + dom_oce_alloc = MAXVAL(ierr) + ! + END FUNCTION dom_oce_alloc + + !!====================================================================== +END MODULE dom_oce diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/domain.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/domain.F90 new file mode 100644 index 0000000..838d72b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/domain.F90 @@ -0,0 +1,721 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_init : initialize the space and time domain + !! dom_glo : initialize global domain <--> local domain indices + !! 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 sbc_oce ! surface boundary condition: ocean + USE trc_oce ! shared ocean & passive tracers variab + USE phycst ! physical constants + USE closea ! closed seas + 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 domvvl ! variable volume + USE c1d ! 1D configuration + USE dyncor_c1d ! 1D configuration: Coriolis term (cor_c1d routine) + USE wet_dry, ONLY : ll_wd + ! + 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 + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_init ! called by nemogcm.F90 + PUBLIC domain_cfg ! called by nemogcm.F90 + + !!------------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!------------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_init(cdstr) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk, ik ! dummy loop indices + INTEGER :: iconf = 0 ! local integers + CHARACTER (len=64) :: cform = "(A12, 3(A13, I7))" + CHARACTER (len=*), INTENT(IN) :: cdstr ! model: NEMO or SAS. Determines core restart variables + 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 : jperio = ', jperio + SELECT CASE ( jperio ) + CASE( 0 ) ; WRITE(numout,*) ' (i.e. closed)' + CASE( 1 ) ; WRITE(numout,*) ' (i.e. cyclic east-west)' + CASE( 2 ) ; WRITE(numout,*) ' (i.e. cyclic north-south)' + CASE( 3 ) ; WRITE(numout,*) ' (i.e. north fold with T-point pivot)' + CASE( 4 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with T-point pivot)' + CASE( 5 ) ; WRITE(numout,*) ' (i.e. north fold with F-point pivot)' + CASE( 6 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north fold with F-point pivot)' + CASE( 7 ) ; WRITE(numout,*) ' (i.e. cyclic east-west and north-south)' + CASE DEFAULT + CALL ctl_stop( 'jperio is out of range' ) + END SELECT + WRITE(numout,*) ' Ocean model configuration used:' + WRITE(numout,*) ' cn_cfg = ', TRIM( cn_cfg ), ' nn_cfg = ', nn_cfg + ENDIF + nn_wxios = 0 + ln_xios_read = .FALSE. + ! + ! !== Reference coordinate system ==! + ! + CALL dom_glo ! global domain versus local domain + CALL dom_nam ! read namelist ( namrun, namdom ) + ! + IF( lwxios ) THEN +!define names for restart write and set core output (restart.F90) + CALL iom_set_rst_vars(rst_wfields) + CALL iom_set_rstw_core(cdstr) + ENDIF +!reset namelist for SAS + IF(cdstr == 'SAS') THEN + IF(lrxios) THEN + IF(lwp) write(numout,*) 'Disable reading restart file using XIOS for SAS' + lrxios = .FALSE. + ENDIF + ENDIF + ! + CALL dom_hgr ! Horizontal mesh + CALL dom_zgr( ik_top, ik_bot ) ! Vertical mesh and bathymetry + CALL dom_msk( ik_top, ik_bot ) ! Masks + IF( ln_closea ) CALL dom_clo ! ln_closea=T : closed seas included in the simulation + ! Read in masks to define closed seas and lakes + ! + DO jj = 1, jpj ! depth of the iceshelves + DO ji = 1, jpi + ik = mikt(ji,jj) + risfdep(ji,jj) = gdepw_0(ji,jj,ik) + END DO + END DO + ! + ht_0(:,:) = 0._wp ! Reference ocean thickness + hu_0(:,:) = 0._wp + hv_0(:,:) = 0._wp + DO jk = 1, jpk + 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 + ! + ! !== time varying part of coordinate system ==! + ! + IF( ln_linssh ) THEN != Fix in time : set to the reference one for all + ! + ! before ! now ! after ! + gdept_b = gdept_0 ; gdept_n = gdept_0 ! --- ! depth of grid-points + gdepw_b = gdepw_0 ; gdepw_n = gdepw_0 ! --- ! + gde3w_n = gde3w_0 ! --- ! + ! + e3t_b = e3t_0 ; e3t_n = e3t_0 ; e3t_a = e3t_0 ! scale factors + e3u_b = e3u_0 ; e3u_n = e3u_0 ; e3u_a = e3u_0 ! + e3v_b = e3v_0 ; e3v_n = e3v_0 ; e3v_a = e3v_0 ! + e3f_n = e3f_0 ! --- ! + e3w_b = e3w_0 ; e3w_n = e3w_0 ! --- ! + e3uw_b = e3uw_0 ; e3uw_n = e3uw_0 ! --- ! + e3vw_b = e3vw_0 ; e3vw_n = e3vw_0 ! --- ! + ! + z1_hu_0(:,:) = ssumask(:,:) / ( hu_0(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF + z1_hv_0(:,:) = ssvmask(:,:) / ( hv_0(:,:) + 1._wp - ssvmask(:,:) ) + ! + ! before ! now ! after ! + ht_n = ht_0 ! ! water column thickness + hu_b = hu_0 ; hu_n = hu_0 ; hu_a = hu_0 ! + hv_b = hv_0 ; hv_n = hv_0 ; hv_a = hv_0 ! + r1_hu_b = z1_hu_0 ; r1_hu_n = z1_hu_0 ; r1_hu_a = z1_hu_0 ! inverse of water column thickness + r1_hv_b = z1_hv_0 ; r1_hv_n = z1_hv_0 ; r1_hv_a = z1_hv_0 ! + ! + ! + ELSE != time varying : initialize before/now/after variables + ! + IF( .NOT.l_offline ) CALL dom_vvl_init + ! + ENDIF + ! + IF( lk_c1d ) CALL cor_c1d ! 1D configuration: Coriolis set at T-point + ! + IF( ln_meshmask .AND. .NOT.ln_iscpl ) CALL dom_wri ! Create a domain file + IF( ln_meshmask .AND. ln_iscpl .AND. .NOT.ln_rstart ) 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_glo + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_glo *** + !! + !! ** Purpose : initialization of global domain <--> local domain indices + !! + !! ** Method : + !! + !! ** Action : - mig , mjg : local domain indices ==> global domain indices + !! - mi0 , mi1 : global domain indices ==> local domain indices + !! - mj0,, mj1 (global point not in the local domain ==> mi0>mi1 and/or mj0>mj1) + !!---------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop argument + !!---------------------------------------------------------------------- + ! + DO ji = 1, jpi ! local domain indices ==> global domain indices + mig(ji) = ji + nimpp - 1 + END DO + DO jj = 1, jpj + mjg(jj) = jj + njmpp - 1 + END DO + ! ! global domain 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 + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) 'dom_glo : domain: global <<==>> local ' + WRITE(numout,*) '~~~~~~~ ' + WRITE(numout,*) ' global domain: jpiglo = ', jpiglo, ' jpjglo = ', jpjglo, ' jpkglo = ', jpkglo + WRITE(numout,*) ' local domain: jpi = ', jpi , ' jpj = ', jpj , ' jpk = ', jpk + WRITE(numout,*) + WRITE(numout,*) ' conversion from local to global domain indices (and vise versa) done' + IF( nn_print >= 1 ) THEN + WRITE(numout,*) + WRITE(numout,*) ' conversion local ==> global i-index domain (mig)' + WRITE(numout,25) (mig(ji),ji = 1,jpi) + WRITE(numout,*) + WRITE(numout,*) ' conversion global ==> local i-index domain' + WRITE(numout,*) ' starting index (mi0)' + WRITE(numout,25) (mi0(ji),ji = 1,jpiglo) + WRITE(numout,*) ' ending index (mi1)' + WRITE(numout,25) (mi1(ji),ji = 1,jpiglo) + WRITE(numout,*) + WRITE(numout,*) ' conversion local ==> global j-index domain (mjg)' + WRITE(numout,25) (mjg(jj),jj = 1,jpj) + WRITE(numout,*) + WRITE(numout,*) ' conversion global ==> local j-index domain' + WRITE(numout,*) ' starting index (mj0)' + WRITE(numout,25) (mj0(jj),jj = 1,jpjglo) + WRITE(numout,*) ' ending index (mj1)' + WRITE(numout,25) (mj1(jj),jj = 1,jpjglo) + ENDIF + ENDIF + 25 FORMAT( 100(10x,19i4,/) ) + ! + END SUBROUTINE dom_glo + + + SUBROUTINE dom_nam + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_nam *** + !! + !! ** Purpose : read domaine namelists and print the variables. + !! + !! ** input : - namrun namelist + !! - namdom namelist + !! - namnc4 namelist ! "key_netcdf4" only + !!---------------------------------------------------------------------- + USE ioipsl + !! + INTEGER :: ios ! Local integer + ! + 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, nn_euler , & + & ln_cfmeta, ln_iscpl, ln_xios_read, nn_wxios, ln_rstdate, ln_rst_eos + + NAMELIST/namdom/ ln_linssh, rn_isfhmin, rn_rdt, rn_atfp, ln_crs, ln_meshmask, ln_2d +#if defined key_netcdf4 + NAMELIST/namnc4/ nn_nchunks_i, nn_nchunks_j, nn_nchunks_k, ln_nc4zip +#endif + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_nam : domain initialization through namelist read' + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + ! + REWIND( numnam_ref ) ! Namelist namrun in reference namelist : Parameters of the run + READ ( numnam_ref, namrun, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namrun in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namrun in configuration namelist : Parameters of the run + 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 nn_euler = ', nn_euler + WRITE(numout,*) ' control of time step nn_rstctl = ', nn_rstctl + WRITE(numout,*) ' number of the first time step nn_it000 = ', nn_it000 + WRITE(numout,*) ' number of the last time step nn_itend = ', nn_itend + WRITE(numout,*) ' initial calendar date aammjj nn_date0 = ', nn_date0 + WRITE(numout,*) ' initial time of day in hhmm nn_time0 = ', nn_time0 + WRITE(numout,*) ' leap year calendar (0/1) nn_leapy = ', nn_leapy + WRITE(numout,*) ' initial state output nn_istate = ', nn_istate + IF( ln_rst_list ) THEN + WRITE(numout,*) ' list of restart dump times nn_stocklist =', nn_stocklist + ELSE + WRITE(numout,*) ' frequency of restart file nn_stock = ', nn_stock + ENDIF +#if ! defined key_iomput + WRITE(numout,*) ' frequency of output file nn_write = ', nn_write +#endif + WRITE(numout,*) ' mask land points ln_mskland = ', ln_mskland + WRITE(numout,*) ' date-stamp restart files ln_rstdate = ', ln_rstdate + 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 + WRITE(numout,*) ' IS coupling at the restart step ln_iscpl = ', ln_iscpl + WRITE(numout,*) ' check restart equation of state ln_rst_eos = ', ln_rst_eos + + 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 + neuler = nn_euler + IF( neuler == 1 .AND. .NOT. ln_rstart ) THEN + 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 : nn_euler is forced to 0 ' + neuler = 0 + ENDIF + ! ! control of output frequency + IF( .NOT. ln_rst_list ) THEN ! we use nn_stock + IF( nn_stock == -1 ) CALL ctl_warn( 'nn_stock = -1 --> no restart will be done' ) + IF( nn_stock == 0 .OR. nn_stock > nitend ) THEN + WRITE(ctmp1,*) 'nn_stock = ', nn_stock, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nn_stock = nitend + ENDIF + ENDIF +#if ! defined key_iomput + IF( nn_write == -1 ) CALL ctl_warn( 'nn_write = -1 --> no output files will be done' ) + IF ( nn_write == 0 ) THEN + WRITE(ctmp1,*) 'nn_write = ', nn_write, ' it is forced to ', nitend + CALL ctl_warn( ctmp1 ) + nn_write = nitend + ENDIF +#endif + +#if defined key_agrif + IF( Agrif_Root() ) THEN +#endif + 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 +#if defined key_agrif + ENDIF +#endif + + REWIND( numnam_ref ) ! Namelist namdom in reference namelist : space & time domain (bathymetry, mesh, timestep) + READ ( numnam_ref, namdom, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdom in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namdom in configuration namelist : space & time domain (bathymetry, mesh, timestep) + 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,*) ' treshold to open the isf cavity rn_isfhmin = ', rn_isfhmin, ' [m]' + WRITE(numout,*) ' ocean time step rn_rdt = ', rn_rdt + WRITE(numout,*) ' asselin time filter parameter rn_atfp = ', rn_atfp + WRITE(numout,*) ' online coarsening of dynamical fields ln_crs = ', ln_crs + WRITE(numout,*) ' 2D mode ln_2d = ', ln_2d + IF(ln_2d) WRITE(numout,*) ' 2D mode active: All tracer processes and vertical diffusion turned off' + ENDIF + ! + ! ! conversion DOCTOR names into model names (this should disappear soon) + atfp = rn_atfp + rdt = rn_rdt + + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + lrxios = ln_xios_read.AND.ln_rstart +!set output file type for XIOS based on NEMO namelist + IF (nn_wxios > 0) lwxios = .TRUE. + nxioso = nn_wxios + ENDIF + +#if defined key_netcdf4 + ! ! NetCDF 4 case ("key_netcdf4" defined) + REWIND( numnam_ref ) ! Namelist namnc4 in reference namelist : NETCDF + READ ( numnam_ref, namnc4, IOSTAT = ios, ERR = 907) +907 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namnc4 in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namnc4 in configuration namelist : NETCDF + READ ( numnam_cfg, namnc4, IOSTAT = ios, ERR = 908 ) +908 IF( ios > 0 ) CALL ctl_nam ( ios , 'namnc4 in configuration namelist' ) + IF(lwm) WRITE( numond, namnc4 ) + + IF(lwp) THEN ! control print + WRITE(numout,*) + WRITE(numout,*) ' Namelist namnc4 - Netcdf4 chunking parameters' + WRITE(numout,*) ' number of chunks in i-dimension nn_nchunks_i = ', nn_nchunks_i + WRITE(numout,*) ' number of chunks in j-dimension nn_nchunks_j = ', nn_nchunks_j + WRITE(numout,*) ' number of chunks in k-dimension nn_nchunks_k = ', nn_nchunks_k + WRITE(numout,*) ' apply netcdf4/hdf5 chunking & compression ln_nc4zip = ', ln_nc4zip + ENDIF + + ! Put the netcdf4 settings into a simple structure (snc4set, defined in in_out_manager module) + ! Note the chunk size in the unlimited (time) dimension will be fixed at 1 + snc4set%ni = nn_nchunks_i + snc4set%nj = nn_nchunks_j + snc4set%nk = nn_nchunks_k + snc4set%luse = ln_nc4zip +#else + snc4set%luse = .FALSE. ! No NetCDF 4 case +#endif + ! + END SUBROUTINE dom_nam + + + SUBROUTINE dom_ctl + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_ctl *** + !! + !! ** Purpose : Domain control. + !! + !! ** Method : compute and print extrema of masked scale factors + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(2) :: imi1, imi2, ima1, ima2 + INTEGER, DIMENSION(2) :: iloc ! + REAL(wp) :: ze1min, ze1max, ze2min, ze2max + !!---------------------------------------------------------------------- + ! + IF(lk_mpp) THEN + CALL mpp_minloc( 'domain', e1t(:,:), tmask_i(:,:), ze1min, imi1 ) + CALL mpp_minloc( 'domain', e2t(:,:), tmask_i(:,:), ze2min, imi2 ) + CALL mpp_maxloc( 'domain', e1t(:,:), tmask_i(:,:), ze1max, ima1 ) + CALL mpp_maxloc( 'domain', e2t(:,:), tmask_i(:,:), ze2max, ima2 ) + ELSE + ze1max = MAXVAL( e1t(:,:)*tmask_i(:,:) ) + ze2max = MAXVAL( e2t(:,:)*tmask_i(:,:) ) + ze1min = ze1max - MAXVAL( (ze1max-e1t(:,:))*tmask_i(:,:) ) + ze2min = ze2max - MAXVAL( (ze2max-e2t(:,:))*tmask_i(:,:) ) + ! + iloc = MAXLOC( (ze1max-e1t(:,:))*tmask_i(:,:) ) + imi1(1) = iloc(1) + nimpp - 1 + imi1(2) = iloc(2) + njmpp - 1 + iloc = MAXLOC( (ze2max-e2t(:,:))*tmask_i(:,:) ) + imi2(1) = iloc(1) + nimpp - 1 + imi2(2) = iloc(2) + njmpp - 1 + iloc = MAXLOC( e1t(:,:)*tmask_i(:,:) ) + ima1(1) = iloc(1) + nimpp - 1 + ima1(2) = iloc(2) + njmpp - 1 + iloc = MAXLOC( e2t(:,:)*tmask_i(:,:) ) + ima2(1) = iloc(1) + nimpp - 1 + ima2(2) = iloc(2) + njmpp - 1 + ENDIF + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dom_ctl : extrema of the masked scale factors' + WRITE(numout,*) '~~~~~~~' + WRITE(numout,"(14x,'e1t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1max, ima1(1), ima1(2) + WRITE(numout,"(14x,'e1t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze1min, imi1(1), imi1(2) + WRITE(numout,"(14x,'e2t maxi: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2max, ima2(1), ima2(2) + WRITE(numout,"(14x,'e2t mini: ',1f10.2,' at i = ',i5,' j= ',i5)") ze2min, imi2(1), imi2(2) + ENDIF + ! + END SUBROUTINE dom_ctl + + + SUBROUTINE domain_cfg( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_nam *** + !! + !! ** 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 + INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. + ! + INTEGER :: inum ! 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 ) + ! + ! !- ORCA family specificity + 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 ) + ! + IF(lwp) THEN + WRITE(numout,*) ' .' + WRITE(numout,*) ' ==>>> ORCA configuration ' + WRITE(numout,*) ' .' + ENDIF + ! + ELSE !- cd_cfg & k_cfg are not used + cd_cfg = 'UNKNOWN' + kk_cfg = -9999999 + !- or they may be present as global attributes + !- (netcdf only) + CALL iom_getatt( inum, 'cn_cfg', cd_cfg ) ! returns ! if not found + CALL iom_getatt( inum, 'nn_cfg', kk_cfg ) ! returns -999 if not found + IF( TRIM(cd_cfg) == '!') cd_cfg = 'UNKNOWN' + IF( kk_cfg == -999 ) kk_cfg = -9999999 + ! + ENDIF + ! + 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_get( inum, 'jperio', zperio ) ; kperio = NINT( zperio ) + CALL iom_close( inum ) + ! + IF(lwp) THEN + WRITE(numout,*) ' cn_cfg = ', TRIM(cd_cfg), ' nn_cfg = ', kk_cfg + WRITE(numout,*) ' jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = ', kpj + WRITE(numout,*) ' jpkglo = ', kpk + WRITE(numout,*) ' type of global domain lateral boundary jperio = ', kperio + 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 :: izco, izps, isco, icav + 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. ) + + ! + ! !== ORCA family specificities ==! + IF( TRIM(cn_cfg) == "orca" .OR. TRIM(cn_cfg) == "ORCA" ) THEN + CALL iom_rstput( 0, 0, inum, 'ORCA' , 1._wp , ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'ORCA_index', REAL( nn_cfg, wp), ktype = jp_i4 ) + ENDIF + ! + ! !== global domain size ==! + ! + CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpk , wp), ktype = jp_i4 ) + ! + ! !== domain characteristics ==! + ! + ! ! lateral boundary of the global domain + CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) + ! + ! ! type of vertical coordinate + IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF + IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF + IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF + CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) + ! + ! ! ocean cavities under iceshelves + IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF + CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) + ! + ! !== 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 + ! + ! Add some global attributes ( netcdf only ) + CALL iom_putatt( inum, 'nn_cfg', nn_cfg ) + CALL iom_putatt( inum, 'cn_cfg', TRIM(cn_cfg) ) + ! + ! ! ============================ + ! ! close the files + ! ! ============================ + CALL iom_close( inum ) + ! + END SUBROUTINE cfg_write + + !!====================================================================== +END MODULE domain diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/domhgr.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/domhgr.F90 new file mode 100644 index 0000000..7fc95bc --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/domhgr.F90 @@ -0,0 +1,235 @@ +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 timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_hgr ! called by domain.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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)) + ! + 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. * omega * SIN( rad * gphif(:,:) ) ! compute it on the sphere at f-point + ff_t(:,:) = 2. * 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 + 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(lwp) WRITE(numout,*) ' u- & v-surfaces have been read in "mesh_mask" file:' + IF(lwp) WRITE(numout,*) ' grid size reduction in strait(s) is used' + 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) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, 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_data, 'glamt', plamt, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'glamu', plamu, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'glamv', plamv, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'glamf', plamf, lrowattr=ln_use_jattr ) + ! + CALL iom_get( inum, jpdom_data, 'gphit', pphit, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'gphiu', pphiu, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'gphiv', pphiv, lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'gphif', pphif, lrowattr=ln_use_jattr ) + ! + CALL iom_get( inum, jpdom_data, 'e1t' , pe1t , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1u' , pe1u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1v' , pe1v , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1f' , pe1f , lrowattr=ln_use_jattr ) + ! + CALL iom_get( inum, jpdom_data, 'e2t' , pe2t , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e2u' , pe2u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e2v' , pe2v , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e2f' , pe2f , lrowattr=ln_use_jattr ) + ! + 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_data, 'ff_f' , pff_f , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'ff_t' , pff_t , lrowattr=ln_use_jattr ) + 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_data, 'e1e2u' , pe1e2u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e1e2v' , pe1e2v , lrowattr=ln_use_jattr ) + ke1e2u_v = 1 + ELSE + ke1e2u_v = 0 + ENDIF + ! + CALL iom_close( inum ) + ! + END SUBROUTINE hgr_read + + !!====================================================================== +END MODULE domhgr diff --git a/MY_SRC/dommsk.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/dommsk.F90 old mode 100755 new mode 100644 similarity index 71% rename from MY_SRC/dommsk.F90 rename to NEMO_4.0.4_surge/src/OCE/DOM/dommsk.F90 index 29d4b88..4f4ad4a --- a/MY_SRC/dommsk.F90 +++ b/NEMO_4.0.4_surge/src/OCE/DOM/dommsk.F90 @@ -25,13 +25,14 @@ MODULE dommsk USE oce ! ocean dynamics and tracers USE dom_oce ! ocean space and time domain USE usrdef_fmask ! user defined fmask - USE bdy_oce + USE bdy_oce ! open boundary + ! USE in_out_manager ! I/O manager - USE iom + USE iom ! IOM library USE lbclnk ! ocean lateral boundary conditions (or mpp link) USE lib_mpp ! Massively Parallel Processing library - USE wrk_nemo ! Memory allocation - USE timing ! Timing + USE iom ! For shlat2d + USE fldread ! for sn_shlat2d IMPLICIT NONE PRIVATE @@ -46,9 +47,9 @@ MODULE dommsk !! * Substitutions # include "vectopt_loop_substitute.h90" !!---------------------------------------------------------------------- - !! NEMO/OPA 3.2 , LODYC-IPSL (2009) - !! $Id: dommsk.F90 7753 2017-03-03 11:46:59Z mocavero $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -92,27 +93,27 @@ SUBROUTINE dom_msk( k_top, k_bot ) INTEGER :: ijf, ijl ! - - INTEGER :: iktop, ikbot ! - - INTEGER :: ios, inum - REAL(wp), POINTER, DIMENSION(:,:) :: zwf ! 2D workspace !! - NAMELIST/namlbc/ rn_shlat, ln_vorlat + REAL(wp) :: zshlat !: locally modified shlat for some strait + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zshlat2d + LOGICAL :: ln_shlat2d + CHARACTER(len = 256) :: cn_shlat2d_file, cn_shlat2d_var + !! + NAMELIST/namlbc/ rn_shlat, ln_vorlat, ln_shlat2d, cn_shlat2d_file, cn_shlat2d_var 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_lim, nn_ice_lim_dta, & - & rn_ice_tem, rn_ice_sal, rn_ice_age, & - & ln_vol, nn_volctl, nn_rimwidth, nb_jpk_bdy + & cn_ice, nn_ice_dta, & + & ln_vol, nn_volctl, nn_rimwidth !!--------------------------------------------------------------------- ! - IF( nn_timing == 1 ) CALL timing_start('dom_msk') - ! REWIND( numnam_ref ) ! Namelist namlbc in reference namelist : Lateral momentum boundary condition READ ( numnam_ref, namlbc, IOSTAT = ios, ERR = 901 ) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist', lwp ) - +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in reference namelist' ) REWIND( numnam_cfg ) ! Namelist namlbc in configuration namelist : Lateral momentum boundary condition READ ( numnam_cfg, namlbc, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist', lwp ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namlbc in configuration namelist' ) IF(lwm) WRITE ( numond, namlbc ) IF(lwp) THEN ! control print @@ -123,17 +124,25 @@ SUBROUTINE dom_msk( k_top, k_bot ) 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 ' + IF ( ln_shlat2d ) THEN + IF(lwp) WRITE(numout,*) ' READ shlat as a 2D coefficient in a file ' + ALLOCATE( zshlat2d(jpi,jpj) ) + CALL iom_open(TRIM(cn_shlat2d_file), inum) + CALL iom_get (inum, jpdom_data, TRIM(cn_shlat2d_var), zshlat2d, 1) ! + CALL iom_close(inum) ELSE - WRITE(ctmp1,*) ' rn_shlat is negative = ', rn_shlat - CALL ctl_stop( ctmp1 ) + 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 ENDIF - ! Ocean/land mask at t-point (computed from ko_top and ko_bot) ! ---------------------------- ! @@ -146,19 +155,19 @@ SUBROUTINE dom_msk( k_top, k_bot ) tmask(ji,jj,iktop:ikbot ) = 1._wp ENDIF END DO - END DO -!SF add here lbc_lnk: bug not still understood : cause now domain configuration is read ! -!!gm I don't understand why... - CALL lbc_lnk( tmask , 'T', 1._wp ) ! Lateral boundary conditions + END DO + ! + ! the following call is mandatory + ! it masks boundaries (bathy=0) where needed depending on the configuration (closed, periodic...) + CALL lbc_lnk( 'dommsk', tmask , 'T', 1._wp ) ! Lateral boundary conditions ! Mask corrections for bdy (read in mppini2) REWIND( numnam_ref ) ! Namelist nambdy in reference namelist :Unstructured open boundaries READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) -903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist', lwp ) - +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist' ) REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist :Unstructured open boundaries READ ( numnam_cfg, nambdy, IOSTAT = ios, ERR = 904 ) -904 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in configuration namelist', lwp ) +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 ) @@ -188,10 +197,7 @@ SUBROUTINE dom_msk( k_top, k_bot ) END DO END DO END DO - CALL lbc_lnk( umask , 'U', 1._wp ) ! Lateral boundary conditions - CALL lbc_lnk( vmask , 'V', 1._wp ) - CALL lbc_lnk( fmask , 'F', 1._wp ) - + CALL lbc_lnk_multi( 'dommsk', umask, 'U', 1., vmask, 'V', 1., fmask, 'F', 1. ) ! Lateral boundary conditions ! Ocean/land mask at wu-, wv- and w points (computed from tmask) !----------------------------------------- @@ -215,8 +221,8 @@ SUBROUTINE dom_msk( k_top, k_bot ) ! Interior domain mask (used for global sum) ! -------------------- ! - iif = jpreci ; iil = nlci - jpreci + 1 - ijf = jprecj ; ijl = nlcj - jprecj + 1 + iif = nn_hls ; iil = nlci - nn_hls + 1 + ijf = nn_hls ; ijl = nlcj - nn_hls + 1 ! ! ! halo mask : 0 on the halo and 1 elsewhere tmask_h(:,:) = 1._wp @@ -249,53 +255,69 @@ SUBROUTINE dom_msk( k_top, k_bot ) ! Lateral boundary conditions on velocity (modify fmask) ! --------------------------------------- - IF( rn_shlat /= 0 ) THEN ! Not free-slip lateral boundary condition - ! - CALL wrk_alloc( jpi,jpj, zwf ) + IF( rn_shlat /= 0 .or. ln_shlat2d ) THEN ! Not free-slip lateral boundary condition everywhere ! DO jk = 1, jpk - zwf(:,:) = fmask(:,:,jk) - DO jj = 2, jpjm1 - DO ji = fs_2, fs_jpim1 ! vector opt. - IF( fmask(ji,jj,jk) == 0._wp ) THEN - fmask(ji,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jj), zwf(ji,jj+1), & - & zwf(ji-1,jj), zwf(ji,jj-1) ) ) - ENDIF + IF ( ln_shlat2d ) THEN + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( fmask(ji,jj,jk) == 0._wp ) THEN + fmask(ji,jj,jk) = zshlat2d(ji,jj) * 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 + ELSE + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + ENDIF DO jj = 2, jpjm1 IF( fmask(1,jj,jk) == 0._wp ) THEN - fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(2,jj), zwf(1,jj+1), zwf(1,jj-1) ) ) + fmask(1 ,jj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(2,jj,jk), umask(1,jj+1,jk), umask(1,jj,jk) ) ) ENDIF IF( fmask(jpi,jj,jk) == 0._wp ) THEN - fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(jpi,jj+1), zwf(jpim1,jj), zwf(jpi,jj-1) ) ) + fmask(jpi,jj,jk) = rn_shlat * MIN( 1._wp , MAX( umask(jpi,jj+1,jk), vmask(jpim1,jj,jk), umask(jpi,jj-1,jk) ) ) ENDIF END DO DO ji = 2, jpim1 IF( fmask(ji,1,jk) == 0._wp ) THEN - fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,1), zwf(ji,2), zwf(ji-1,1) ) ) + fmask(ji, 1 ,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,1,jk), umask(ji,2,jk), vmask(ji,1,jk) ) ) ENDIF IF( fmask(ji,jpj,jk) == 0._wp ) THEN - fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( zwf(ji+1,jpj), zwf(ji-1,jpj), zwf(ji,jpjm1) ) ) + fmask(ji,jpj,jk) = rn_shlat * MIN( 1._wp , MAX( vmask(ji+1,jpj,jk), vmask(ji-1,jpj,jk), umask(ji,jpjm1,jk) ) ) ENDIF END DO +#if defined key_agrif + IF( .NOT. AGRIF_Root() ) THEN + IF ( l_Eastedge ) fmask(nlci-1 , : ,jk) = 0.e0 ! east + IF ( l_Westedge ) fmask(1 , : ,jk) = 0.e0 ! west + IF ( l_Northedge ) fmask(: ,nlcj-1 ,jk) = 0.e0 ! north + IF ( l_Southedge ) fmask(: ,1 ,jk) = 0.e0 ! south + ENDIF +#endif END DO ! - CALL wrk_dealloc( jpi,jpj, zwf ) + IF( ln_shlat2d ) DEALLOCATE( zshlat2d ) ! - CALL lbc_lnk( fmask, 'F', 1._wp ) ! Lateral boundary conditions on fmask + 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) + ! Only call if we are not using the shlat2d option. ! -------------------------------- ! - CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) - ! - ! - IF( nn_timing == 1 ) CALL timing_stop('dom_msk') + IF ( .not. ln_shlat2d ) THEN + CALL usr_def_fmask( cn_cfg, nn_cfg, fmask ) + ENDIF ! END SUBROUTINE dom_msk diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/domngb.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/domngb.F90 new file mode 100644 index 0000000..ad48c6e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/domngb.F90 @@ -0,0 +1,81 @@ +MODULE domngb + !!====================================================================== + !! *** MODULE domngb *** + !! Grid search: find the closest grid point from a given on/lat position + !!====================================================================== + !! History : 3.2 ! 2009-11 (S. Masson) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_ngb : find the closest grid point from a given lon/lat position + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! for mppsum + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_ngb ! routine called in iom.F90 module + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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, zmask, zdist + !!-------------------------------------------------------------------- + ! + zmask(:,:) = 0._wp + ik = 1 + IF ( PRESENT(kkk) ) ik=kkk + SELECT CASE( cdgrid ) + CASE( 'U' ) ; zglam(:,:) = glamu(:,:) ; zgphi(:,:) = gphiu(:,:) ; zmask(nldi:nlei,nldj:nlej) = umask(nldi:nlei,nldj:nlej,ik) + CASE( 'V' ) ; zglam(:,:) = glamv(:,:) ; zgphi(:,:) = gphiv(:,:) ; zmask(nldi:nlei,nldj:nlej) = vmask(nldi:nlei,nldj:nlej,ik) + CASE( 'F' ) ; zglam(:,:) = glamf(:,:) ; zgphi(:,:) = gphif(:,:) ; zmask(nldi:nlei,nldj:nlej) = fmask(nldi:nlei,nldj:nlej,ik) + CASE DEFAULT ; zglam(:,:) = glamt(:,:) ; zgphi(:,:) = gphit(:,:) ; zmask(nldi:nlei,nldj:nlej) = tmask(nldi:nlei,nldj:nlej,ik) + 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(:,:) + + IF( lk_mpp ) THEN + CALL mpp_minloc( 'domngb', zdist(:,:), zmask, zmini, iloc) + kii = iloc(1) ; kjj = iloc(2) + ELSE + zmini = MAXVAL( zdist(:,:)*zmask(:,:) ) + iloc(:) = MAXLOC( (zmini-zdist(:,:))*zmask(:,:) ) + kii = iloc(1) + nimpp - 1 + kjj = iloc(2) + njmpp - 1 + ENDIF + ! + END SUBROUTINE dom_ngb + + !!====================================================================== +END MODULE domngb diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/domvvl.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/domvvl.F90 new file mode 100644 index 0000000..23dc2ae --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/domvvl.F90 @@ -0,0 +1,1052 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_vvl_init : define initial vertical scale factors, depths and column thickness + !! dom_vvl_sf_nxt : Compute next vertical scale factors + !! dom_vvl_sf_swp : Swap vertical scale factors and update the vertical grid + !! dom_vvl_interpol : Interpolate vertical scale factors from one grid point to another + !! dom_vvl_rst : read/write restart file + !! dom_vvl_ctl : Check the vvl options + !!---------------------------------------------------------------------- + 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 + + PUBLIC dom_vvl_init ! called by domain.F90 + PUBLIC dom_vvl_sf_nxt ! called by step.F90 + PUBLIC dom_vvl_sf_swp ! called by step.F90 + PUBLIC dom_vvl_interpol ! called by dynnxt.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 + 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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dom_vvl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION dom_vvl_alloc *** + !!---------------------------------------------------------------------- + IF( ln_vvl_zstar ) dom_vvl_alloc = 0 + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + ALLOCATE( tilde_e3t_b(jpi,jpj,jpk) , tilde_e3t_n(jpi,jpj,jpk) , tilde_e3t_a(jpi,jpj,jpk) , & + & dtilde_e3t_a(jpi,jpj,jpk) , un_td (jpi,jpj,jpk) , vn_td (jpi,jpj,jpk) , & + & STAT = dom_vvl_alloc ) + CALL mpp_sum ( 'domvvl', dom_vvl_alloc ) + IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_alloc: failed to allocate arrays' ) + un_td = 0._wp + vn_td = 0._wp + ENDIF + IF( ln_vvl_ztilde ) THEN + ALLOCATE( frq_rst_e3t(jpi,jpj) , frq_rst_hdv(jpi,jpj) , hdiv_lf(jpi,jpj,jpk) , STAT= dom_vvl_alloc ) + CALL mpp_sum ( 'domvvl', dom_vvl_alloc ) + IF( dom_vvl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_alloc: failed to allocate arrays' ) + ENDIF + ! + END FUNCTION dom_vvl_alloc + + + SUBROUTINE dom_vvl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_init *** + !! + !! ** Purpose : Initialization of all scale factors, depths + !! and water column heights + !! + !! ** Method : - use restart file and/or initialize + !! - interpolate scale factors + !! + !! ** Action : - e3t_(n/b) and tilde_e3t_(n/b) + !! - Regrid: e3(u/v)_n + !! e3(u/v)_b + !! e3w_n + !! e3(u/v)w_b + !! e3(u/v)w_n + !! gdept_n, gdepw_n and gde3w_n + !! - h(t/u/v)_0 + !! - frq_rst_e3t and frq_rst_hdv + !! + !! Reference : Leclair, M., and G. Madec, 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk + INTEGER :: ii0, ii1, ij0, ij1 + REAL(wp):: zcoef + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_vvl_init : Variable volume activated' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ! + CALL dom_vvl_ctl ! choose vertical coordinate (z_star, z_tilde or layer) + ! + ! ! Allocate module arrays + IF( dom_vvl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'dom_vvl_init : unable to allocate arrays' ) + ! + ! ! Read or initialize e3t_(b/n), tilde_e3t_(b/n) and hdiv_lf + CALL dom_vvl_rst( nit000, 'READ' ) + e3t_a(:,:,jpk) = e3t_0(:,:,jpk) ! last level always inside the sea floor set one for all + ! + ! !== Set of all other vertical scale factors ==! (now and before) + ! ! Horizontal interpolation of e3t + CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' ) ! from T to U + CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' ) ! from T to V + CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) ! from U to F + ! ! Vertical interpolation of e3t,u,v + CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' ) ! from T to W + CALL dom_vvl_interpol( e3t_b(:,:,:), e3w_b (:,:,:), 'W' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) ! from U to UW + CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) ! from V to UW + CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) + + ! We need to define e3[tuv]_a for AGRIF initialisation (should not be a problem for the restartability...) + e3t_a(:,:,:) = e3t_n(:,:,:) + e3u_a(:,:,:) = e3u_n(:,:,:) + e3v_a(:,:,:) = e3v_n(:,:,:) + ! + ! !== depth of t and w-point ==! (set the isf depth as it is in the initial timestep) + gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) ! reference to the ocean surface (used for MLD and light penetration) + gdepw_n(:,:,1) = 0.0_wp + gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:) ! reference to a common level z=0 for hpg + gdept_b(:,:,1) = 0.5_wp * e3w_b(:,:,1) + gdepw_b(:,:,1) = 0.0_wp + DO jk = 2, jpk ! vertical sum + DO jj = 1,jpj + DO ji = 1,jpi + ! zcoef = tmask - wmask ! 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 = ( tmask(ji,jj,jk) - wmask(ji,jj,jk) ) + gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1) + gdept_n(ji,jj,jk) = zcoef * ( gdepw_n(ji,jj,jk ) + 0.5 * e3w_n(ji,jj,jk)) & + & + (1-zcoef) * ( gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk)) + gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - sshn(ji,jj) + gdepw_b(ji,jj,jk) = gdepw_b(ji,jj,jk-1) + e3t_b(ji,jj,jk-1) + gdept_b(ji,jj,jk) = zcoef * ( gdepw_b(ji,jj,jk ) + 0.5 * e3w_b(ji,jj,jk)) & + & + (1-zcoef) * ( gdept_b(ji,jj,jk-1) + e3w_b(ji,jj,jk)) + END DO + END DO + END DO + ! + ! !== thickness of the water column !! (ocean portion only) + ht_n(:,:) = e3t_n(:,:,1) * tmask(:,:,1) !!gm BUG : this should be 1/2 * e3w(k=1) .... + hu_b(:,:) = e3u_b(:,:,1) * umask(:,:,1) + hu_n(:,:) = e3u_n(:,:,1) * umask(:,:,1) + hv_b(:,:) = e3v_b(:,:,1) * vmask(:,:,1) + hv_n(:,:) = e3v_n(:,:,1) * vmask(:,:,1) + DO jk = 2, jpkm1 + ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk) + hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk) + hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk) + hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk) + hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk) + END DO + ! + ! !== inverse of water column thickness ==! (u- and v- points) + r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) ) ! _i mask due to ISF + r1_hu_n(:,:) = ssumask(:,:) / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) ) + r1_hv_n(:,:) = ssvmask(:,:) / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) + + ! !== z_tilde coordinate case ==! (Restoring frequencies) + IF( ln_vvl_ztilde ) THEN +!!gm : idea: add here a READ in a file of custumized restoring frequency + ! ! Values in days provided via the namelist + ! ! use rsmall to avoid possible division by zero errors with faulty settings + frq_rst_e3t(:,:) = 2._wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.0_wp ) + frq_rst_hdv(:,:) = 2._wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.0_wp ) + ! + IF( ln_vvl_ztilde_as_zstar ) THEN ! z-star emulation using z-tile + frq_rst_e3t(:,:) = 0._wp !Ignore namelist settings + frq_rst_hdv(:,:) = 1._wp / rdt + ENDIF + IF ( ln_vvl_zstar_at_eqtor ) THEN ! use z-star in vicinity of the Equator + DO jj = 1, jpj + DO ji = 1, jpi +!!gm case |gphi| >= 6 degrees is useless initialized just above by default + IF( ABS(gphit(ji,jj)) >= 6.) THEN + ! values outside the equatorial band and transition zone (ztilde) + frq_rst_e3t(ji,jj) = 2.0_wp * rpi / ( MAX( rn_rst_e3t , rsmall ) * 86400.e0_wp ) + frq_rst_hdv(ji,jj) = 2.0_wp * rpi / ( MAX( rn_lf_cutoff, rsmall ) * 86400.e0_wp ) + ELSEIF( ABS(gphit(ji,jj)) <= 2.5) THEN ! Equator strip ==> z-star + ! values inside the equatorial band (ztilde as zstar) + frq_rst_e3t(ji,jj) = 0.0_wp + frq_rst_hdv(ji,jj) = 1.0_wp / rdt + ELSE ! transition band (2.5 to 6 degrees N/S) + ! ! (linearly transition from z-tilde to z-star) + frq_rst_e3t(ji,jj) = 0.0_wp + (frq_rst_e3t(ji,jj)-0.0_wp)*0.5_wp & + & * ( 1.0_wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) & + & * 180._wp / 3.5_wp ) ) + frq_rst_hdv(ji,jj) = (1.0_wp / rdt) & + & + ( frq_rst_hdv(ji,jj)-(1.e0_wp / rdt) )*0.5_wp & + & * ( 1._wp - COS( rad*(ABS(gphit(ji,jj))-2.5_wp) & + & * 180._wp / 3.5_wp ) ) + ENDIF + END DO + END DO + IF( cn_cfg == "orca" .OR. cn_cfg == "ORCA" ) THEN + IF( nn_cfg == 3 ) THEN ! ORCA2: Suppress ztilde in the Foxe Basin for ORCA2 + ii0 = 103 ; ii1 = 111 + ij0 = 128 ; ij1 = 135 ; + frq_rst_e3t( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 0.0_wp + frq_rst_hdv( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) ) = 1.e0_wp / rdt + ENDIF + ENDIF + ENDIF + ENDIF + ! + IF(lwxios) THEN +! define variables in restart file when writing with XIOS + CALL iom_set_rstw_var_active('e3t_b') + CALL iom_set_rstw_var_active('e3t_n') + ! ! ----------------------- ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! + ! ! ----------------------- ! + CALL iom_set_rstw_var_active('tilde_e3t_b') + CALL iom_set_rstw_var_active('tilde_e3t_n') + END IF + ! ! -------------! + IF( ln_vvl_ztilde ) THEN ! z_tilde case ! + ! ! ------------ ! + CALL iom_set_rstw_var_active('hdiv_lf') + ENDIF + ! + ENDIF + ! + END SUBROUTINE dom_vvl_init + + + SUBROUTINE dom_vvl_sf_nxt( kt, kcall ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_sf_nxt *** + !! + !! ** Purpose : - compute the after scale factors used in tra_zdf, dynnxt, + !! tranxt and dynspg routines + !! + !! ** Method : - z_star case: Repartition of ssh INCREMENT proportionnaly to the level thickness. + !! - z_tilde_case: after scale factor increment = + !! high frequency part of horizontal divergence + !! + retsoring towards the background grid + !! + thickness difusion + !! Then repartition of ssh INCREMENT proportionnaly + !! to the "baroclinic" level thickness. + !! + !! ** Action : - hdiv_lf : restoring towards full baroclinic divergence in z_tilde case + !! - tilde_e3t_a: after increment of vertical scale factor + !! in z_tilde case + !! - e3(t/u/v)_a + !! + !! Reference : Leclair, M., and Madec, G. 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time step + INTEGER, INTENT( in ), OPTIONAL :: kcall ! optional argument indicating call sequence + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER , DIMENSION(3) :: ijk_max, ijk_min ! temporary integers + REAL(wp) :: z2dt, z_tmin, z_tmax ! local scalars + LOGICAL :: ll_do_bclinic ! local logical + REAL(wp), DIMENSION(jpi,jpj) :: zht, z_scale, zwu, zwv, zhdiv + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t + !!---------------------------------------------------------------------- + ! + IF( ln_linssh ) RETURN ! No calculation in linear free surface + ! + IF( ln_timing ) CALL timing_start('dom_vvl_sf_nxt') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_vvl_sf_nxt : compute after scale factors' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~' + ENDIF + + ll_do_bclinic = .TRUE. + IF( PRESENT(kcall) ) THEN + IF( kcall == 2 .AND. ln_vvl_ztilde ) ll_do_bclinic = .FALSE. + ENDIF + + ! ******************************* ! + ! After acale factors at t-points ! + ! ******************************* ! + ! ! --------------------------------------------- ! + ! ! z_star coordinate and barotropic z-tilde part ! + ! ! --------------------------------------------- ! + ! + z_scale(:,:) = ( ssha(:,:) - sshb(:,:) ) * ssmask(:,:) / ( ht_0(:,:) + sshn(:,:) + 1. - ssmask(:,:) ) + DO jk = 1, jpkm1 + ! formally this is the same as e3t_a = e3t_0*(1+ssha/ht_0) + e3t_a(:,:,jk) = e3t_b(:,:,jk) + e3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) + END DO + ! + IF( (ln_vvl_ztilde .OR. ln_vvl_layer) .AND. ll_do_bclinic ) THEN ! z_tilde or layer coordinate ! + ! ! ------baroclinic part------ ! + ! I - initialization + ! ================== + + ! 1 - barotropic divergence + ! ------------------------- + zhdiv(:,:) = 0._wp + zht(:,:) = 0._wp + DO jk = 1, jpkm1 + zhdiv(:,:) = zhdiv(:,:) + e3t_n(:,:,jk) * hdivn(:,:,jk) + zht (:,:) = zht (:,:) + e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + zhdiv(:,:) = zhdiv(:,:) / ( zht(:,:) + 1. - tmask_i(:,:) ) + + ! 2 - Low frequency baroclinic horizontal divergence (z-tilde case only) + ! -------------------------------------------------- + IF( ln_vvl_ztilde ) THEN + IF( kt > nit000 ) THEN + DO jk = 1, jpkm1 + hdiv_lf(:,:,jk) = hdiv_lf(:,:,jk) - rdt * frq_rst_hdv(:,:) & + & * ( hdiv_lf(:,:,jk) - e3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) ) + END DO + ENDIF + ENDIF + + ! II - after z_tilde increments of vertical scale factors + ! ======================================================= + tilde_e3t_a(:,:,:) = 0._wp ! tilde_e3t_a used to store tendency terms + + ! 1 - High frequency divergence term + ! ---------------------------------- + IF( ln_vvl_ztilde ) THEN ! z_tilde case + DO jk = 1, jpkm1 + tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - ( e3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) - hdiv_lf(:,:,jk) ) + END DO + ELSE ! layer case + DO jk = 1, jpkm1 + tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - e3t_n(:,:,jk) * ( hdivn(:,:,jk) - zhdiv(:,:) ) * tmask(:,:,jk) + END DO + ENDIF + + ! 2 - Restoring term (z-tilde case only) + ! ------------------ + IF( ln_vvl_ztilde ) THEN + DO jk = 1, jpk + tilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - frq_rst_e3t(:,:) * tilde_e3t_b(:,:,jk) + END DO + ENDIF + + ! 3 - Thickness diffusion term + ! ---------------------------- + zwu(:,:) = 0._wp + zwv(:,:) = 0._wp + DO jk = 1, jpkm1 ! a - first derivative: diffusive fluxes + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + un_td(ji,jj,jk) = rn_ahe3 * umask(ji,jj,jk) * e2_e1u(ji,jj) & + & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji+1,jj ,jk) ) + vn_td(ji,jj,jk) = rn_ahe3 * vmask(ji,jj,jk) * e1_e2v(ji,jj) & + & * ( tilde_e3t_b(ji,jj,jk) - tilde_e3t_b(ji ,jj+1,jk) ) + zwu(ji,jj) = zwu(ji,jj) + un_td(ji,jj,jk) + zwv(ji,jj) = zwv(ji,jj) + vn_td(ji,jj,jk) + END DO + END DO + END DO + DO jj = 1, jpj ! b - correction for last oceanic u-v points + DO ji = 1, jpi + un_td(ji,jj,mbku(ji,jj)) = un_td(ji,jj,mbku(ji,jj)) - zwu(ji,jj) + vn_td(ji,jj,mbkv(ji,jj)) = vn_td(ji,jj,mbkv(ji,jj)) - zwv(ji,jj) + END DO + END DO + DO jk = 1, jpkm1 ! c - second derivative: divergence of diffusive fluxes + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + tilde_e3t_a(ji,jj,jk) = tilde_e3t_a(ji,jj,jk) + ( un_td(ji-1,jj ,jk) - un_td(ji,jj,jk) & + & + vn_td(ji ,jj-1,jk) - vn_td(ji,jj,jk) & + & ) * r1_e1e2t(ji,jj) + END DO + END DO + END DO + ! ! d - thickness diffusion transport: boundary conditions + ! (stored for tracer advction and continuity equation) + CALL lbc_lnk_multi( 'domvvl', un_td , 'U' , -1._wp, vn_td , 'V' , -1._wp) + + ! 4 - Time stepping of baroclinic scale factors + ! --------------------------------------------- + ! Leapfrog time stepping + ! ~~~~~~~~~~~~~~~~~~~~~~ + IF( neuler == 0 .AND. kt == nit000 ) THEN + z2dt = rdt + ELSE + z2dt = 2.0_wp * rdt + ENDIF + CALL lbc_lnk( 'domvvl', tilde_e3t_a(:,:,:), 'T', 1._wp ) + tilde_e3t_a(:,:,:) = tilde_e3t_b(:,:,:) + z2dt * tmask(:,:,:) * tilde_e3t_a(:,:,:) + + ! Maximum deformation control + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ze3t(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ze3t(:,:,jk) = tilde_e3t_a(:,:,jk) / e3t_0(:,:,jk) * tmask(:,:,jk) * tmask_i(:,:) + END DO + z_tmax = MAXVAL( ze3t(:,:,:) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + z_tmin = MINVAL( ze3t(:,:,:) ) + CALL mpp_min( 'domvvl', z_tmin ) ! min over the global domain + ! - ML - test: for the moment, stop simulation for too large e3_t variations + IF( ( z_tmax > rn_zdef_max ) .OR. ( z_tmin < - rn_zdef_max ) ) THEN + IF( lk_mpp ) THEN + CALL mpp_maxloc( 'domvvl', ze3t, tmask, z_tmax, ijk_max ) + CALL mpp_minloc( 'domvvl', ze3t, tmask, z_tmin, ijk_min ) + ELSE + ijk_max = MAXLOC( ze3t(:,:,:) ) + ijk_max(1) = ijk_max(1) + nimpp - 1 + ijk_max(2) = ijk_max(2) + njmpp - 1 + ijk_min = MINLOC( ze3t(:,:,:) ) + ijk_min(1) = ijk_min(1) + nimpp - 1 + ijk_min(2) = ijk_min(2) + njmpp - 1 + ENDIF + IF (lwp) THEN + WRITE(numout, *) 'MAX( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmax + WRITE(numout, *) 'at i, j, k=', ijk_max + WRITE(numout, *) 'MIN( tilde_e3t_a(:,:,:) / e3t_0(:,:,:) ) =', z_tmin + WRITE(numout, *) 'at i, j, k=', ijk_min + CALL ctl_stop( 'STOP', 'MAX( ABS( tilde_e3t_a(:,:,: ) ) / e3t_0(:,:,:) ) too high') + ENDIF + ENDIF + ! - ML - end test + ! - ML - Imposing these limits will cause a baroclinicity error which is corrected for below + tilde_e3t_a(:,:,:) = MIN( tilde_e3t_a(:,:,:), rn_zdef_max * e3t_0(:,:,:) ) + tilde_e3t_a(:,:,:) = MAX( tilde_e3t_a(:,:,:), - rn_zdef_max * e3t_0(:,:,:) ) + + ! + ! "tilda" change in the after scale factor + ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + DO jk = 1, jpkm1 + dtilde_e3t_a(:,:,jk) = tilde_e3t_a(:,:,jk) - tilde_e3t_b(:,:,jk) + END DO + ! III - Barotropic repartition of the sea surface height over the baroclinic profile + ! ================================================================================== + ! add ( ssh increment + "baroclinicity error" ) proportionly to e3t(n) + ! - ML - baroclinicity error should be better treated in the future + ! i.e. locally and not spread over the water column. + ! (keep in mind that the idea is to reduce Eulerian velocity as much as possible) + zht(:,:) = 0. + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + tilde_e3t_a(:,:,jk) * tmask(:,:,jk) + END DO + z_scale(:,:) = - zht(:,:) / ( ht_0(:,:) + sshn(:,:) + 1. - ssmask(:,:) ) + DO jk = 1, jpkm1 + dtilde_e3t_a(:,:,jk) = dtilde_e3t_a(:,:,jk) + e3t_n(:,:,jk) * z_scale(:,:) * tmask(:,:,jk) + END DO + + ENDIF + + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde or layer coordinate ! + ! ! ---baroclinic part--------- ! + DO jk = 1, jpkm1 + e3t_a(:,:,jk) = e3t_a(:,:,jk) + dtilde_e3t_a(:,:,jk) * tmask(:,:,jk) + END DO + ENDIF + + IF( ln_vvl_dbg .AND. .NOT. ll_do_bclinic ) THEN ! - ML - test: control prints for debuging + ! + IF( lwp ) WRITE(numout, *) 'kt =', kt + IF ( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(SUM(tilde_e3t_a))) =', z_tmax + END IF + ! + zht(:,:) = 0.0_wp + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshn(:,:) - zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshn-SUM(e3t_n))) =', z_tmax + ! + zht(:,:) = 0.0_wp + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + e3t_a(:,:,jk) * tmask(:,:,jk) + END DO + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + ssha(:,:) - zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+ssha-SUM(e3t_a))) =', z_tmax + ! + zht(:,:) = 0.0_wp + DO jk = 1, jpkm1 + zht(:,:) = zht(:,:) + e3t_b(:,:,jk) * tmask(:,:,jk) + END DO + z_tmax = MAXVAL( tmask(:,:,1) * tmask_i(:,:) * ABS( ht_0(:,:) + sshb(:,:) - zht(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ht_0+sshb-SUM(e3t_b))) =', z_tmax + ! + z_tmax = MAXVAL( tmask(:,:,1) * ABS( sshb(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(sshb))) =', z_tmax + ! + z_tmax = MAXVAL( tmask(:,:,1) * ABS( sshn(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(sshn))) =', z_tmax + ! + z_tmax = MAXVAL( tmask(:,:,1) * ABS( ssha(:,:) ) ) + CALL mpp_max( 'domvvl', z_tmax ) ! max over the global domain + IF( lwp ) WRITE(numout, *) kt,' MAXVAL(abs(ssha))) =', z_tmax + END IF + + ! *********************************** ! + ! After scale factors at u- v- points ! + ! *********************************** ! + + CALL dom_vvl_interpol( e3t_a(:,:,:), e3u_a(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_a(:,:,:), e3v_a(:,:,:), 'V' ) + + ! *********************************** ! + ! After depths at u- v points ! + ! *********************************** ! + + hu_a(:,:) = e3u_a(:,:,1) * umask(:,:,1) + hv_a(:,:) = e3v_a(:,:,1) * vmask(:,:,1) + DO jk = 2, jpkm1 + hu_a(:,:) = hu_a(:,:) + e3u_a(:,:,jk) * umask(:,:,jk) + hv_a(:,:) = hv_a(:,:) + e3v_a(:,:,jk) * vmask(:,:,jk) + END DO + ! ! Inverse of the local depth +!!gm BUG ? don't understand the use of umask_i here ..... + r1_hu_a(:,:) = ssumask(:,:) / ( hu_a(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_a(:,:) = ssvmask(:,:) / ( hv_a(:,:) + 1._wp - ssvmask(:,:) ) + ! + IF( ln_timing ) CALL timing_stop('dom_vvl_sf_nxt') + ! + END SUBROUTINE dom_vvl_sf_nxt + + + SUBROUTINE dom_vvl_sf_swp( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_sf_swp *** + !! + !! ** Purpose : compute time filter and swap of scale factors + !! compute all depths and related variables for next time step + !! write outputs and restart file + !! + !! ** Method : - swap of e3t with trick for volume/tracer conservation + !! - reconstruct scale factor at other grid points (interpolate) + !! - recompute depths and water height fields + !! + !! ** Action : - e3t_(b/n), tilde_e3t_(b/n) and e3(u/v)_n ready for next time step + !! - Recompute: + !! e3(u/v)_b + !! e3w_n + !! e3(u/v)w_b + !! e3(u/v)w_n + !! gdept_n, gdepw_n and gde3w_n + !! h(u/v) and h(u/v)r + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !! Leclair, M., and G. Madec, 2011, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! time step + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_linssh ) RETURN ! No calculation in linear free surface + ! + IF( ln_timing ) CALL timing_start('dom_vvl_sf_swp') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dom_vvl_sf_swp : - time filter and swap of scale factors' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ - interpolate scale factors and compute depths for next time step' + ENDIF + ! + ! Time filter and swap of scale factors + ! ===================================== + ! - ML - e3(t/u/v)_b are allready computed in dynnxt. + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + IF( neuler == 0 .AND. kt == nit000 ) THEN + tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) + ELSE + tilde_e3t_b(:,:,:) = tilde_e3t_n(:,:,:) & + & + atfp * ( tilde_e3t_b(:,:,:) - 2.0_wp * tilde_e3t_n(:,:,:) + tilde_e3t_a(:,:,:) ) + ENDIF + tilde_e3t_n(:,:,:) = tilde_e3t_a(:,:,:) + ENDIF + gdept_b(:,:,:) = gdept_n(:,:,:) + gdepw_b(:,:,:) = gdepw_n(:,:,:) + + e3t_n(:,:,:) = e3t_a(:,:,:) + e3u_n(:,:,:) = e3u_a(:,:,:) + e3v_n(:,:,:) = e3v_a(:,:,:) + + ! Compute all missing vertical scale factor and depths + ! ==================================================== + ! Horizontal scale factor interpolations + ! -------------------------------------- + ! - ML - e3u_b and e3v_b are allready computed in dynnxt + ! - JC - hu_b, hv_b, hur_b, hvr_b also + + CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) + + ! Vertical scale factor interpolations + CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n(:,:,:), 'W' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) + CALL dom_vvl_interpol( e3t_b(:,:,:), e3w_b(:,:,:), 'W' ) + CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) + + ! t- and w- points depth (set the isf depth as it is in the initial step) + gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) + gdepw_n(:,:,1) = 0.0_wp + gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:) + DO jk = 2, jpk + DO jj = 1,jpj + DO ji = 1,jpi + ! zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) ! 0 everywhere tmask = wmask, ie everywhere expect at jk = mikt + ! 1 for jk = mikt + zcoef = (tmask(ji,jj,jk) - wmask(ji,jj,jk)) + gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1) + gdept_n(ji,jj,jk) = zcoef * ( gdepw_n(ji,jj,jk ) + 0.5 * e3w_n(ji,jj,jk) ) & + & + (1-zcoef) * ( gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk) ) + gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk) - sshn(ji,jj) + END DO + END DO + END DO + + ! Local depth and Inverse of the local depth of the water + ! ------------------------------------------------------- + hu_n(:,:) = hu_a(:,:) ; r1_hu_n(:,:) = r1_hu_a(:,:) + hv_n(:,:) = hv_a(:,:) ; r1_hv_n(:,:) = r1_hv_a(:,:) + ! + ht_n(:,:) = e3t_n(:,:,1) * tmask(:,:,1) + DO jk = 2, jpkm1 + ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + + ! write restart file + ! ================== + IF( lrst_oce ) CALL dom_vvl_rst( kt, 'WRITE' ) + ! + IF( ln_timing ) CALL timing_stop('dom_vvl_sf_swp') + ! + END SUBROUTINE dom_vvl_sf_swp + + + SUBROUTINE dom_vvl_interpol( pe3_in, pe3_out, pout ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_vvl__interpol *** + !! + !! ** Purpose : interpolate scale factors from one grid point to another + !! + !! ** Method : e3_out = e3_0 + interpolation(e3_in - e3_0) + !! - horizontal interpolation: grid cell surface averaging + !! - vertical interpolation: simple averaging + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3_out ! output interpolated e3 + CHARACTER(LEN=*) , INTENT(in ) :: pout ! grid point of out scale factors + ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW' + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zlnwd ! =1./0. when ln_wd_il = T/F + !!---------------------------------------------------------------------- + ! + IF(ln_wd_il) THEN + zlnwd = 1.0_wp + ELSE + zlnwd = 0.0_wp + END IF + ! + SELECT CASE ( pout ) !== type of interpolation ==! + ! + CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean + DO jk = 1, jpk + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * ( pe3_in(ji ,jj,jk) - e3t_0(ji ,jj,jk) ) & + & + e1e2t(ji+1,jj) * ( pe3_in(ji+1,jj,jk) - e3t_0(ji+1,jj,jk) ) ) + END DO + END DO + END DO + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'U', 1._wp ) + pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) + ! + CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean + DO jk = 1, jpk + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pe3_out(ji,jj,jk) = 0.5_wp * ( vmask(ji,jj,jk) * (1.0_wp - zlnwd) + zlnwd ) * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3t_0(ji,jj ,jk) ) & + & + e1e2t(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3t_0(ji,jj+1,jk) ) ) + END DO + END DO + END DO + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'V', 1._wp ) + pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) + ! + CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean + DO jk = 1, jpk + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pe3_out(ji,jj,jk) = 0.5_wp * ( umask(ji,jj,jk) * umask(ji,jj+1,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * r1_e1e2f(ji,jj) & + & * ( e1e2u(ji,jj ) * ( pe3_in(ji,jj ,jk) - e3u_0(ji,jj ,jk) ) & + & + e1e2u(ji,jj+1) * ( pe3_in(ji,jj+1,jk) - e3u_0(ji,jj+1,jk) ) ) + END DO + END DO + END DO + CALL lbc_lnk( 'domvvl', pe3_out(:,:,:), 'F', 1._wp ) + pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) + ! + CASE( 'W' ) !* from T- to W-point : vertical simple mean + ! + pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) + ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing +!!gm BUG? use here wmask in case of ISF ? to be checked + DO jk = 2, jpk + pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) & + & + 0.5_wp * ( tmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,:,jk ) - e3t_0(:,:,jk ) ) + END DO + ! + CASE( 'UW' ) !* from U- to UW-point : vertical simple mean + ! + pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) + ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing +!!gm BUG? use here wumask in case of ISF ? to be checked + DO jk = 2, jpk + pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) & + & + 0.5_wp * ( umask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,:,jk ) - e3u_0(:,:,jk ) ) + END DO + ! + CASE( 'VW' ) !* from V- to VW-point : vertical simple mean + ! + pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) + ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing +!!gm BUG? use here wvmask in case of ISF ? to be checked + DO jk = 2, jpk + pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) ) & + & * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) & + & + 0.5_wp * ( vmask(:,:,jk) * (1.0_wp - zlnwd) + zlnwd ) & + & * ( pe3_in(:,:,jk ) - e3v_0(:,:,jk ) ) + END DO + END SELECT + ! + END SUBROUTINE dom_vvl_interpol + + + SUBROUTINE dom_vvl_rst( kt, cdrw ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_rst *** + !! + !! ** Purpose : Read or write VVL file in restart file + !! + !! ** Method : use of IOM library + !! if the restart does not contain vertical scale factors, + !! they are set to the _0 values + !! if the restart does not contain vertical scale factors increments (z_tilde), + !! they are set to 0. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! ocean time-step + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + ! + INTEGER :: ji, jj, jk + INTEGER :: id1, id2, id3, id4, id5 ! local integers + !!---------------------------------------------------------------------- + ! + IF( TRIM(cdrw) == 'READ' ) THEN ! Read/initialise + ! ! =============== + IF( ln_rstart ) THEN !* Read the restart file + CALL rst_read_open ! open the restart file if necessary + CALL iom_get( numror, jpdom_autoglo, 'sshn' , sshn, ldxios = lrxios ) + ! + id1 = iom_varid( numror, 'e3t_b', ldstop = .FALSE. ) + id2 = iom_varid( numror, 'e3t_n', ldstop = .FALSE. ) + id3 = iom_varid( numror, 'tilde_e3t_b', ldstop = .FALSE. ) + id4 = iom_varid( numror, 'tilde_e3t_n', ldstop = .FALSE. ) + id5 = iom_varid( numror, 'hdiv_lf', ldstop = .FALSE. ) + ! ! --------- ! + ! ! all cases ! + ! ! --------- ! + IF( MIN( id1, id2 ) > 0 ) THEN ! all required arrays exist + CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t_b(:,:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t_n(:,:,:), ldxios = lrxios ) + ! needed to restart if land processor not computed + IF(lwp) write(numout,*) 'dom_vvl_rst : e3t_b and e3t_n found in restart files' + WHERE ( tmask(:,:,:) == 0.0_wp ) + e3t_n(:,:,:) = e3t_0(:,:,:) + e3t_b(:,:,:) = e3t_0(:,:,:) + END WHERE + IF( neuler == 0 ) THEN + e3t_b(:,:,:) = e3t_n(:,:,:) + ENDIF + ELSE IF( id1 > 0 ) THEN + IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t_n not found in restart files' + IF(lwp) write(numout,*) 'e3t_n set equal to e3t_b.' + IF(lwp) write(numout,*) 'neuler is forced to 0' + CALL iom_get( numror, jpdom_autoglo, 'e3t_b', e3t_b(:,:,:), ldxios = lrxios ) + e3t_n(:,:,:) = e3t_b(:,:,:) + neuler = 0 + ELSE IF( id2 > 0 ) THEN + IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t_b not found in restart files' + IF(lwp) write(numout,*) 'e3t_b set equal to e3t_n.' + IF(lwp) write(numout,*) 'neuler is forced to 0' + CALL iom_get( numror, jpdom_autoglo, 'e3t_n', e3t_n(:,:,:), ldxios = lrxios ) + e3t_b(:,:,:) = e3t_n(:,:,:) + neuler = 0 + ELSE + IF(lwp) write(numout,*) 'dom_vvl_rst WARNING : e3t_n not found in restart file' + IF(lwp) write(numout,*) 'Compute scale factor from sshn' + IF(lwp) write(numout,*) 'neuler is forced to 0' + DO jk = 1, jpk + e3t_n(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) & + & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & + & + e3t_0(:,:,jk) * (1._wp -tmask(:,:,jk)) + END DO + e3t_b(:,:,:) = e3t_n(:,:,:) + neuler = 0 + ENDIF + ! ! ----------- ! + IF( ln_vvl_zstar ) THEN ! z_star case ! + ! ! ----------- ! + IF( MIN( id3, id4 ) > 0 ) THEN + CALL ctl_stop( 'dom_vvl_rst: z_star cannot restart from a z_tilde or layer run' ) + ENDIF + ! ! ----------------------- ! + ELSE ! z_tilde and layer cases ! + ! ! ----------------------- ! + IF( MIN( id3, id4 ) > 0 ) THEN ! all required arrays exist + CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lrxios ) + ELSE ! one at least array is missing + tilde_e3t_b(:,:,:) = 0.0_wp + tilde_e3t_n(:,:,:) = 0.0_wp + ENDIF + ! ! ------------ ! + IF( ln_vvl_ztilde ) THEN ! z_tilde case ! + ! ! ------------ ! + IF( id5 > 0 ) THEN ! required array exists + CALL iom_get( numror, jpdom_autoglo, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lrxios ) + ELSE ! array is missing + hdiv_lf(:,:,:) = 0.0_wp + ENDIF + ENDIF + ENDIF + ! + ELSE !* Initialize at "rest" + ! + + IF( ll_wd ) THEN ! MJB ll_wd edits start here - these are essential + ! + IF( cn_cfg == 'wad' ) THEN + ! Wetting and drying test case + CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb ) + tsn (:,:,:,:) = tsb (:,:,:,:) ! set now values from to before ones + sshn (:,:) = sshb(:,:) + un (:,:,:) = ub (:,:,:) + vn (:,:,:) = vb (:,:,:) + ELSE + ! if not test case + sshn(:,:) = -ssh_ref + sshb(:,:) = -ssh_ref + + DO jj = 1, jpj + DO ji = 1, jpi + IF( ht_0(ji,jj)-ssh_ref < rn_wdmin1 ) THEN ! if total depth is less than min depth + + sshb(ji,jj) = rn_wdmin1 - (ht_0(ji,jj) ) + sshn(ji,jj) = rn_wdmin1 - (ht_0(ji,jj) ) + ssha(ji,jj) = rn_wdmin1 - (ht_0(ji,jj) ) + ENDIF + ENDDO + ENDDO + ENDIF !If test case else + + ! Adjust vertical metrics for all wad + DO jk = 1, jpk + e3t_n(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshn(:,:) ) & + & / ( ht_0(:,:) + 1._wp - ssmask(:,:) ) * tmask(:,:,jk) & + & + e3t_0(:,:,jk) * ( 1._wp - tmask(:,:,jk) ) + END DO + e3t_b(:,:,:) = e3t_n(:,:,:) + + DO ji = 1, jpi + DO jj = 1, jpj + IF ( ht_0(ji,jj) .LE. 0.0 .AND. NINT( ssmask(ji,jj) ) .EQ. 1) THEN + CALL ctl_stop( 'dom_vvl_rst: ht_0 must be positive at potentially wet points' ) + ENDIF + END DO + END DO + ! + ELSE + ! + ! Just to read set ssh in fact, called latter once vertical grid + ! is set up: +! CALL usr_def_istate( gdept_0, tmask, tsb, ub, vb, sshb ) +! ! +! DO jk=1,jpk +! e3t_b(:,:,jk) = e3t_0(:,:,jk) * ( ht_0(:,:) + sshb(:,:) ) & +! & / ( ht_0(:,:) + 1._wp -ssmask(:,:) ) * tmask(:,:,jk) +! END DO +! e3t_n(:,:,:) = e3t_b(:,:,:) + sshn(:,:)=0._wp + e3t_n(:,:,:)=e3t_0(:,:,:) + e3t_b(:,:,:)=e3t_0(:,:,:) + ! + END IF ! end of ll_wd edits + + IF( ln_vvl_ztilde .OR. ln_vvl_layer) THEN + tilde_e3t_b(:,:,:) = 0._wp + tilde_e3t_n(:,:,:) = 0._wp + IF( ln_vvl_ztilde ) hdiv_lf(:,:,:) = 0._wp + END IF + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! =================== + IF(lwp) WRITE(numout,*) '---- dom_vvl_rst ----' + IF( lwxios ) CALL iom_swap( cwxios_context ) + ! ! --------- ! + ! ! all cases ! + ! ! --------- ! + CALL iom_rstput( kt, nitrst, numrow, 'e3t_b', e3t_b(:,:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t_n(:,:,:), ldxios = lwxios ) + ! ! ----------------------- ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! z_tilde and layer cases ! + ! ! ----------------------- ! + CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_b', tilde_e3t_b(:,:,:), ldxios = lwxios) + CALL iom_rstput( kt, nitrst, numrow, 'tilde_e3t_n', tilde_e3t_n(:,:,:), ldxios = lwxios) + END IF + ! ! -------------! + IF( ln_vvl_ztilde ) THEN ! z_tilde case ! + ! ! ------------ ! + CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:), ldxios = lwxios) + ENDIF + ! + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + END SUBROUTINE dom_vvl_rst + + + SUBROUTINE dom_vvl_ctl + !!--------------------------------------------------------------------- + !! *** ROUTINE dom_vvl_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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist nam_vvl in reference namelist : + READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist nam_vvl in configuration namelist : Parameters of the run + 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,*) 'dom_vvl_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/rdt' + 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( .NOT. ln_vvl_zstar .AND. ln_isf ) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) + ! + 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 + ! +#if defined key_agrif + IF( (.NOT.Agrif_Root()).AND.(.NOT.ln_vvl_zstar) ) CALL ctl_stop( 'AGRIF is implemented with zstar coordinate only' ) +#endif + ! + END SUBROUTINE dom_vvl_ctl + + !!====================================================================== +END MODULE domvvl diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/domwri.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/domwri.F90 new file mode 100644 index 0000000..530686a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/domwri.F90 @@ -0,0 +1,296 @@ +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_uniq : identify unique point of a grid (TUVF) + !! dom_stiff : diagnose maximum grid stiffness/hydrostatic consistency (s-coordinate) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + INTEGER :: izco, izps, isco, icav + ! + 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. ) + ! + ! ! global domain size + CALL iom_rstput( 0, 0, inum, 'jpiglo', REAL( jpiglo, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'jpjglo', REAL( jpjglo, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'jpkglo', REAL( jpkglo, wp), ktype = jp_i4 ) + + ! ! domain characteristics + CALL iom_rstput( 0, 0, inum, 'jperio', REAL( jperio, wp), ktype = jp_i4 ) + ! ! type of vertical coordinate + IF( ln_zco ) THEN ; izco = 1 ; ELSE ; izco = 0 ; ENDIF + IF( ln_zps ) THEN ; izps = 1 ; ELSE ; izps = 0 ; ENDIF + IF( ln_sco ) THEN ; isco = 1 ; ELSE ; isco = 0 ; ENDIF + CALL iom_rstput( 0, 0, inum, 'ln_zco' , REAL( izco, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'ln_zps' , REAL( izps, wp), ktype = jp_i4 ) + CALL iom_rstput( 0, 0, inum, 'ln_sco' , REAL( isco, wp), ktype = jp_i4 ) + ! ! ocean cavities under iceshelves + IF( ln_isfcav ) THEN ; icav = 1 ; ELSE ; icav = 0 ; ENDIF + CALL iom_rstput( 0, 0, inum, 'ln_isfcav', REAL( icav, wp), ktype = jp_i4 ) + + ! ! 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 = 1, jpj + DO ji = 1, jpi + zprt(ji,jj) = ssmask(ji,jj) * zprw(ji,jj) ! ! unique point mask + END DO + END DO ! ! unique point mask + CALL iom_rstput( 0, 0, inum, 'tmaskutil', zprt, ktype = jp_i1 ) + CALL dom_uniq( zprw, 'U' ) + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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(:,:) = ssmask(:,:) * REAL( mbkt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'mbathy', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points + zprt(:,:) = ssmask(:,:) * REAL( mikt(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'misf', zprt, ktype = jp_i4 ) ! ! nb of ocean T-points + zprt(:,:) = ssmask(:,:) * REAL( risfdep(:,:) , wp ) + CALL iom_rstput( 0, 0, inum, 'isfdraft', zprt, ktype = jp_r8 ) ! ! 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_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(SIZE(puniq,1),SIZE(puniq,2),1) :: lldbl ! 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 = jpi * jpj * ( 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. ) ! apply boundary conditions + lldbl(:,:,1) = puniq(:,:) == ztstref(:,:) ! check which values have been changed + ! + puniq(:,:) = 1. ! default definition + ! fill only the inner part of the cpu with llbl converted into real + puniq(nldi:nlei,nldj:nlej) = REAL( COUNT( lldbl(nldi:nlei,nldj:nlej,:), dim = 3 ) , wp ) + ! + END SUBROUTINE dom_uniq + + + 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 ji = 2, jpim1 + DO jj = 2, jpjm1 + DO jk = 1, jpkm1 +!!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. ) + ! + 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/NEMO_4.0.4_surge/src/OCE/DOM/domzgr.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/domzgr.F90 new file mode 100644 index 0000000..c64f25f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/domzgr.F90 @@ -0,0 +1,319 @@ +MODULE domzgr + !!============================================================================== + !! *** MODULE domzgr *** + !! Ocean domain : definition of the vertical coordinate system + !!============================================================================== + !! History : OPA ! 1995-12 (G. Madec) Original code : s vertical coordinate + !! ! 1997-07 (G. Madec) lbc_lnk call + !! ! 1997-04 (J.-O. Beismann) + !! 8.5 ! 2002-09 (A. Bozec, G. Madec) F90: Free form and module + !! - ! 2002-09 (A. de Miranda) rigid-lid + islands + !! NEMO 1.0 ! 2003-08 (G. Madec) F90: Free form and module + !! - ! 2005-10 (A. Beckmann) modifications for hybrid s-ccordinates & new stretching function + !! 2.0 ! 2006-04 (R. Benshila, G. Madec) add zgr_zco + !! 3.0 ! 2008-06 (G. Madec) insertion of domzgr_zps.h90 & conding style + !! 3.2 ! 2009-07 (R. Benshila) Suppression of rigid-lid option + !! 3.3 ! 2010-11 (G. Madec) add mbk. arrays associated to the deepest ocean level + !! 3.4 ! 2012-08 (J. Siddorn) added Siddorn and Furner stretching function + !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) modify C1D case + !! 3.6 ! 2014-11 (P. Mathiot and C. Harris) add ice shelf capabilitye + !! 3.? ! 2015-11 (H. Liu) Modifications for Wetting/Drying + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dom_zgr : read or set the ocean vertical coordinate system + !! zgr_read : read the vertical information in the domain configuration file + !! zgr_top_bot : ocean top and bottom level for t-, u, and v-points with 1 as minimum value + !!--------------------------------------------------------------------- + USE oce ! ocean variables + USE dom_oce ! ocean domain + USE usrdef_zgr ! user defined vertical coordinate system + USE closea ! closed seas + USE depth_e3 ! depth <=> e3 + USE wet_dry, ONLY: ll_wd, ssh_ref ! Wetting and drying + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE lib_mpp ! distributed memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC dom_zgr ! called by dom_init.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dom_zgr( k_top, k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dom_zgr *** + !! + !! ** Purpose : set the depth of model levels and the resulting + !! vertical scale factors. + !! + !! ** Method : - reference 1D vertical coordinate (gdep._1d, e3._1d) + !! - read/set ocean depth and ocean levels (bathy, mbathy) + !! - vertical coordinate (gdep., e3.) depending on the + !! coordinate chosen : + !! ln_zco=T z-coordinate + !! ln_zps=T z-coordinate with partial steps + !! ln_zco=T s-coordinate + !! + !! ** Action : define gdep., e3., mbathy and bathy + !!---------------------------------------------------------------------- + INTEGER, DIMENSION(:,:), INTENT(out) :: k_top, k_bot ! ocean first and last level indices + ! + INTEGER :: jk ! dummy loop index + INTEGER :: ioptio, ibat, ios ! local integer + REAL(wp) :: zrefdep ! depth of the reference level (~10m) + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'dom_zgr : vertical coordinate' + WRITE(numout,*) '~~~~~~~' + ENDIF + + IF( ln_linssh .AND. lwp) WRITE(numout,*) ' linear free surface: the vertical mesh does not change in time' + + + IF( ln_read_cfg ) THEN !== read in mesh_mask.nc file ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> Read vertical mesh in ', TRIM( cn_domcfg ), ' file' + ! + CALL zgr_read ( ln_zco , ln_zps , ln_sco, ln_isfcav, & + & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth + & gdept_0 , gdepw_0 , & ! gridpoints depth + & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors + & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors + & k_top , k_bot ) ! 1st & last ocean level + ! + ELSE !== User defined configuration ==! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' User defined vertical mesh (usr_def_zgr)' + ! + CALL usr_def_zgr( ln_zco , ln_zps , ln_sco, ln_isfcav, & + & gdept_1d, gdepw_1d, e3t_1d, e3w_1d , & ! 1D gridpoints depth + & gdept_0 , gdepw_0 , & ! gridpoints depth + & e3t_0 , e3u_0 , e3v_0 , e3f_0 , & ! vertical scale factors + & e3w_0 , e3uw_0 , e3vw_0 , & ! vertical scale factors + & k_top , k_bot ) ! 1st & last ocean level + ! + ENDIF + ! +!!gm to be remove when removing the OLD definition of e3 scale factors so that gde3w disappears + ! Compute gde3w_0 (vertical sum of e3w) + gde3w_0(:,:,1) = 0.5_wp * e3w_0(:,:,1) + DO jk = 2, jpk + gde3w_0(:,:,jk) = gde3w_0(:,:,jk-1) + e3w_0(:,:,jk) + END DO + ! + ! Any closed seas (defined by closea_mask > 0 in domain_cfg file) to be filled + ! in at runtime if ln_closea=.false. + IF( .NOT.ln_closea ) CALL clo_bat( k_top, k_bot ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) ' Type of vertical coordinate (read in ', TRIM( cn_domcfg ), ' file or set in userdef_nam) :' + WRITE(numout,*) ' z-coordinate - full steps ln_zco = ', ln_zco + WRITE(numout,*) ' z-coordinate - partial steps ln_zps = ', ln_zps + WRITE(numout,*) ' s- or hybrid z-s-coordinate ln_sco = ', ln_sco + WRITE(numout,*) ' ice shelf cavities ln_isfcav = ', ln_isfcav + ENDIF + + ioptio = 0 ! Check Vertical coordinate options + IF( ln_zco ) ioptio = ioptio + 1 + IF( ln_zps ) ioptio = ioptio + 1 + IF( ln_sco ) ioptio = ioptio + 1 + IF( ioptio /= 1 ) CALL ctl_stop( ' none or several vertical coordinate options used' ) + IF (ln_2d .AND. .NOT.ln_sco) CALL ctl_stop( ' 2D mode must be used with ln_sco' ) + + ! ! top/bottom ocean level indices for t-, u- and v-points (f-point also for top) + CALL zgr_top_bot( k_top, k_bot ) ! with a minimum value set to 1 + + + ! ! deepest/shallowest W level Above/Below ~10m +!!gm BUG in s-coordinate this does not work! + zrefdep = 10._wp - 0.1_wp * MINVAL( e3w_1d ) ! ref. depth with tolerance (10% of minimum layer thickness) + nlb10 = MINLOC( gdepw_1d, mask = gdepw_1d > zrefdep, dim = 1 ) ! shallowest W level Below ~10m + nla10 = nlb10 - 1 ! deepest W level Above ~10m +!!gm end bug + ! + IF( nprint == 1 .AND. lwp ) THEN + WRITE(numout,*) ' MIN val k_top ', MINVAL( k_top(:,:) ), ' MAX ', MAXVAL( k_top(:,:) ) + WRITE(numout,*) ' MIN val k_bot ', MINVAL( k_bot(:,:) ), ' MAX ', MAXVAL( k_bot(:,:) ) + WRITE(numout,*) ' MIN val depth t ', MINVAL( gdept_0(:,:,:) ), & + & ' w ', MINVAL( gdepw_0(:,:,:) ), '3w ', MINVAL( gde3w_0(:,:,:) ) + WRITE(numout,*) ' MIN val e3 t ', MINVAL( e3t_0(:,:,:) ), ' f ', MINVAL( e3f_0(:,:,:) ), & + & ' u ', MINVAL( e3u_0(:,:,:) ), ' u ', MINVAL( e3v_0(:,:,:) ), & + & ' uw', MINVAL( e3uw_0(:,:,:) ), ' vw', MINVAL( e3vw_0(:,:,:)), & + & ' w ', MINVAL( e3w_0(:,:,:) ) + + WRITE(numout,*) ' MAX val depth t ', MAXVAL( gdept_0(:,:,:) ), & + & ' w ', MAXVAL( gdepw_0(:,:,:) ), '3w ', MAXVAL( gde3w_0(:,:,:) ) + WRITE(numout,*) ' MAX val e3 t ', MAXVAL( e3t_0(:,:,:) ), ' f ', MAXVAL( e3f_0(:,:,:) ), & + & ' u ', MAXVAL( e3u_0(:,:,:) ), ' u ', MAXVAL( e3v_0(:,:,:) ), & + & ' uw', MAXVAL( e3uw_0(:,:,:) ), ' vw', MAXVAL( e3vw_0(:,:,:) ), & + & ' w ', MAXVAL( e3w_0(:,:,:) ) + ENDIF + ! + END SUBROUTINE dom_zgr + + + SUBROUTINE zgr_read( ld_zco , ld_zps , ld_sco , ld_isfcav, & ! type of vertical coordinate + & pdept_1d, pdepw_1d, pe3t_1d , pe3w_1d , & ! 1D reference vertical coordinate + & pdept , pdepw , & ! 3D t & w-points depth + & pe3t , pe3u , pe3v , pe3f , & ! vertical scale factors + & pe3w , pe3uw , pe3vw , & ! - - - + & k_top , k_bot ) ! top & bottom ocean level + !!--------------------------------------------------------------------- + !! *** ROUTINE zgr_read *** + !! + !! ** Purpose : Read the vertical information in the domain configuration file + !! + !!---------------------------------------------------------------------- + LOGICAL , INTENT(out) :: ld_zco, ld_zps, ld_sco ! vertical coordinate flags + LOGICAL , INTENT(out) :: ld_isfcav ! under iceshelf cavity flag + REAL(wp), DIMENSION(:) , INTENT(out) :: pdept_1d, pdepw_1d ! 1D grid-point depth [m] + REAL(wp), DIMENSION(:) , INTENT(out) :: pe3t_1d , pe3w_1d ! 1D vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pdept, pdepw ! grid-point depth [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3t , pe3u , pe3v , pe3f ! vertical scale factors [m] + REAL(wp), DIMENSION(:,:,:), INTENT(out) :: pe3w , pe3uw, pe3vw ! - - - + INTEGER , DIMENSION(:,:) , INTENT(out) :: k_top , k_bot ! first & last ocean level + ! + INTEGER :: jk ! dummy loop index + INTEGER :: inum ! local logical unit + REAL(WP) :: z_zco, z_zps, z_sco, z_cav + REAL(wp), DIMENSION(jpi,jpj) :: z2d ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' zgr_read : read the vertical coordinates in ', TRIM( cn_domcfg ), ' file' + WRITE(numout,*) ' ~~~~~~~~' + ENDIF + ! + CALL iom_open( cn_domcfg, inum ) + ! + ! !* type of vertical coordinate + CALL iom_get( inum, 'ln_zco' , z_zco ) + CALL iom_get( inum, 'ln_zps' , z_zps ) + CALL iom_get( inum, 'ln_sco' , z_sco ) + IF( z_zco == 0._wp ) THEN ; ld_zco = .false. ; ELSE ; ld_zco = .true. ; ENDIF + IF( z_zps == 0._wp ) THEN ; ld_zps = .false. ; ELSE ; ld_zps = .true. ; ENDIF + IF( z_sco == 0._wp ) THEN ; ld_sco = .false. ; ELSE ; ld_sco = .true. ; ENDIF + ! + ! !* ocean cavities under iceshelves + CALL iom_get( inum, 'ln_isfcav', z_cav ) + IF( z_cav == 0._wp ) THEN ; ld_isfcav = .false. ; ELSE ; ld_isfcav = .true. ; ENDIF + ! + ! !* vertical scale factors + CALL iom_get( inum, jpdom_unknown, 'e3t_1d' , pe3t_1d ) ! 1D reference coordinate + CALL iom_get( inum, jpdom_unknown, 'e3w_1d' , pe3w_1d ) + ! + CALL iom_get( inum, jpdom_data, 'e3t_0' , pe3t , lrowattr=ln_use_jattr ) ! 3D coordinate + CALL iom_get( inum, jpdom_data, 'e3u_0' , pe3u , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3v_0' , pe3v , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3f_0' , pe3f , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3w_0' , pe3w , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3uw_0' , pe3uw , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data, 'e3vw_0' , pe3vw , lrowattr=ln_use_jattr ) + ! + ! !* depths + ! !- old depth definition (obsolescent feature) + IF( iom_varid( inum, 'gdept_1d', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdepw_1d', ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdept_0' , ldstop = .FALSE. ) > 0 .AND. & + & iom_varid( inum, 'gdepw_0' , ldstop = .FALSE. ) > 0 ) THEN + CALL ctl_warn( 'zgr_read : old definition of depths and scale factors used ', & + & ' depths at t- and w-points read in the domain configuration file') + CALL iom_get( inum, jpdom_unknown, 'gdept_1d', pdept_1d ) + CALL iom_get( inum, jpdom_unknown, 'gdepw_1d', pdepw_1d ) + CALL iom_get( inum, jpdom_data , 'gdept_0' , pdept , lrowattr=ln_use_jattr ) + CALL iom_get( inum, jpdom_data , 'gdepw_0' , pdepw , lrowattr=ln_use_jattr ) + ! + ELSE !- depths computed from e3. scale factors + CALL e3_to_depth( pe3t_1d, pe3w_1d, pdept_1d, pdepw_1d ) ! 1D reference depth + CALL e3_to_depth( pe3t , pe3w , pdept , pdepw ) ! 3D depths + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' Reference 1D z-coordinate depth and scale factors:' + WRITE(numout, "(9x,' level gdept_1d gdepw_1d e3t_1d e3w_1d ')" ) + WRITE(numout, "(10x, i4, 4f9.2)" ) ( jk, pdept_1d(jk), pdepw_1d(jk), pe3t_1d(jk), pe3w_1d(jk), jk = 1, jpk ) + ENDIF + ENDIF + ! + ! !* ocean top and bottom level + CALL iom_get( inum, jpdom_data, 'top_level' , z2d , lrowattr=ln_use_jattr ) ! 1st wet T-points (ISF) + k_top(:,:) = NINT( z2d(:,:) ) + CALL iom_get( inum, jpdom_data, 'bottom_level' , z2d , lrowattr=ln_use_jattr ) ! last wet T-points + k_bot(:,:) = NINT( z2d(:,:) ) + ! + ! reference depth for negative bathy (wetting and drying only) + IF( ll_wd ) CALL iom_get( inum, 'rn_wd_ref_depth' , ssh_ref ) + ! + CALL iom_close( inum ) + ! + END SUBROUTINE zgr_read + + + SUBROUTINE zgr_top_bot( k_top, k_bot ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zgr_top_bot *** + !! + !! ** Purpose : defines the vertical index of ocean bottom (mbk. arrays) + !! + !! ** Method : computes from k_top and k_bot with a minimum value of 1 over land + !! + !! ** Action : mikt, miku, mikv : vertical indices of the shallowest + !! ocean level at t-, u- & v-points + !! (min value = 1) + !! ** Action : mbkt, mbku, mbkv : vertical indices of the deeptest + !! ocean level at t-, u- & v-points + !! (min value = 1 over land) + !!---------------------------------------------------------------------- + INTEGER , DIMENSION(:,:), INTENT(in) :: k_top, k_bot ! top & bottom ocean level indices + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zk ! workspace + !!---------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' zgr_top_bot : ocean top and bottom k-index of T-, U-, V- and W-levels ' + IF(lwp) WRITE(numout,*) ' ~~~~~~~~~~~' + ! + mikt(:,:) = MAX( k_top(:,:) , 1 ) ! top ocean k-index of T-level (=1 over land) + ! + mbkt(:,:) = MAX( k_bot(:,:) , 1 ) ! bottom ocean k-index of T-level (=1 over land) + + ! ! N.B. top k-index of W-level = mikt + ! ! bottom k-index of W-level = mbkt+1 + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + miku(ji,jj) = MAX( mikt(ji+1,jj ) , mikt(ji,jj) ) + mikv(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj) ) + mikf(ji,jj) = MAX( mikt(ji ,jj+1) , mikt(ji,jj), mikt(ji+1,jj ), mikt(ji+1,jj+1) ) + ! + mbku(ji,jj) = MIN( mbkt(ji+1,jj ) , mbkt(ji,jj) ) + mbkv(ji,jj) = MIN( mbkt(ji ,jj+1) , mbkt(ji,jj) ) + END DO + END DO + ! converte into REAL to use lbc_lnk ; impose a min value of 1 as a zero can be set in lbclnk + zk(:,:) = REAL( miku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; miku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mikv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mikv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mikf(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'F', 1. ) ; mikf(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + zk(:,:) = REAL( mbku(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'U', 1. ) ; mbku(:,:) = MAX( NINT( zk(:,:) ), 1 ) + zk(:,:) = REAL( mbkv(:,:), wp ) ; CALL lbc_lnk( 'domzgr', zk, 'V', 1. ) ; mbkv(:,:) = MAX( NINT( zk(:,:) ), 1 ) + ! + END SUBROUTINE zgr_top_bot + + !!====================================================================== +END MODULE domzgr diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/dtatsd.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/dtatsd.F90 new file mode 100644 index 0000000..253a615 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/dtatsd.F90 @@ -0,0 +1,257 @@ +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 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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + ! + REWIND( numnam_ref ) ! Namelist namtsd in reference namelist : + READ ( numnam_ref, namtsd, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtsd in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namtsd in configuration namelist : Parameters of the run + 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 + IF( ln_2d ) WRITE(numout,*) ' 2D ocean - ocean will be started at rest and T&S = arbitrary constants' + 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 + !! - 'key_orca_lev10' interpolates on 10 times more levels + !! - s- or mixed z-s coordinate: vertical interpolation on model mesh + !! - ln_tsd_dmp=F: deallocates the T-S data structure + !! as T-S data are no are used + !! + !! ** Action : ptsd T-S data on medl mesh and interpolated at time-step kt + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step + REAL(wp), DIMENSION(jpi,jpj,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 + REAL(wp):: zl, zi ! local scalars + REAL(wp), DIMENSION(jpk) :: ztp, zsp ! 1D workspace + !!---------------------------------------------------------------------- + ! + 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 + ! + ij0 = 101 ; ij1 = 109 ! Reduced T & S in the Alboran Sea + ii0 = 141 ; ii1 = 155 + 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 + ! + 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 + ij0 = 87 ; ij1 = 96 ! Reduced temperature in Red Sea + ii0 = 148 ; ii1 = 160 + 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 + ! + ptsd(:,:,:,jp_tem) = sf_tsd(jp_tem)%fnow(:,:,:) ! NO mask + ptsd(:,:,:,jp_sal) = sf_tsd(jp_sal)%fnow(:,:,:) + ! + IF( ln_sco ) THEN !== s- or mixed s-zps-coordinate ==! + ! + 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 + ! + DO jj = 1, jpj ! vertical interpolation of T & S + DO ji = 1, jpi + 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 ==! + ! + ptsd(:,:,:,jp_tem) = ptsd(:,:,:,jp_tem) * tmask(:,:,:) ! Mask + ptsd(:,:,:,jp_sal) = ptsd(:,:,:,jp_sal) * tmask(:,:,:) + ! + IF( ln_zps ) THEN ! zps-coordinate (partial steps) interpolation at the last ocean level + DO jj = 1, jpj + DO ji = 1, jpi + 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/NEMO_4.0.4_surge/src/OCE/DOM/iscplhsb.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/iscplhsb.F90 new file mode 100644 index 0000000..5d1d2cd --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/iscplhsb.F90 @@ -0,0 +1,324 @@ +MODULE iscplhsb + !!====================================================================== + !! *** MODULE iscplhsb *** + !! Ocean forcing: ice sheet/ocean coupling (conservation) + !!===================================================================== + !! History : NEMO ! 2015-01 P. Mathiot: original + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iscpl_alloc : variable allocation + !! iscpl_hsb : compute and store the input of heat/salt/volume + !! into the system due to the coupling process + !! iscpl_div : correction of divergence to keep volume conservation + !!---------------------------------------------------------------------- + USE oce ! global tra/dyn variable + USE dom_oce ! ocean space and time domain + USE domwri ! ocean space and time domain + USE domngb ! + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition variables + USE iscplini ! + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + USE lib_fortran ! MPP library + USE lbclnk ! + + IMPLICIT NONE + PRIVATE + + PUBLIC iscpl_div + PUBLIC iscpl_cons + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iscpl_cons(ptmask_b, psmask_b, pe3t_b, pts_flx, pvol_flx, prdt_iscpl) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_cons *** + !! + !! ** Purpose : compute input into the system during the coupling step + !! compute the correction term + !! compute where the correction have to be applied + !! + !! ** Method : compute tsn*e3t-tsb*e3tb and e3t-e3t_b + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: ptmask_b !! mask before + REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pe3t_b !! scale factor before + REAL(wp), DIMENSION(:,: ), INTENT(in ) :: psmask_b !! mask before + REAL(wp), DIMENSION(:,:,:,:), INTENT(out) :: pts_flx !! corrective flux to have tracer conservation + REAL(wp), DIMENSION(:,:,: ), INTENT(out) :: pvol_flx !! corrective flux to have volume conservation + REAL(wp), INTENT(in ) :: prdt_iscpl !! coupling period + ! + INTEGER :: ji , jj , jk ! loop index + INTEGER :: jip1, jim1, jjp1, jjm1 + REAL(wp) :: summsk, zsum , zsumn, zjip1_ratio , zjim1_ratio, zdtem, zde3t, z1_rdtiscpl + REAL(wp) :: zarea , zsum1, zsumb, zjjp1_ratio , zjjm1_ratio, zdsal + REAL(wp), DIMENSION(jpi,jpj) :: zdssh ! workspace + REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon, zlat + REAL(wp), DIMENSION(:), ALLOCATABLE :: zcorr_vol, zcorr_tem, zcorr_sal + INTEGER , DIMENSION(:), ALLOCATABLE :: ixpts, iypts, izpts, inpts + INTEGER :: jpts, npts + !!---------------------------------------------------------------------- + + ! get imbalance (volume heat and salt) + ! initialisation difference + zde3t = 0._wp ; zdsal = 0._wp ; zdtem = 0._wp + + ! initialisation correction term + pvol_flx(:,:,: ) = 0._wp + pts_flx (:,:,:,:) = 0._wp + + z1_rdtiscpl = 1._wp / prdt_iscpl + + ! mask tsn and tsb + tsb(:,:,:,jp_tem) = tsb(:,:,:,jp_tem) * ptmask_b(:,:,:) + tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask (:,:,:) + tsb(:,:,:,jp_sal) = tsb(:,:,:,jp_sal) * ptmask_b(:,:,:) + tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask (:,:,:) + + !============================================================================== + ! diagnose the heat, salt and volume input and compute the correction variable + !============================================================================== + + ! + zdssh(:,:) = sshn(:,:) * ssmask(:,:) - sshb(:,:) * psmask_b(:,:) + IF (.NOT. ln_linssh ) zdssh = 0.0_wp ! already included in the levels by definition + + DO jk = 1,jpk-1 + DO jj = 2,jpj-1 + DO ji = fs_2,fs_jpim1 + IF (tmask_h(ji,jj) == 1._wp) THEN + + ! volume differences + zde3t = e3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk) + + ! heat diff + zdtem = tsn(ji,jj,jk,jp_tem) * e3t_n(ji,jj,jk) * tmask (ji,jj,jk) & + - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk) + ! salt diff + zdsal = tsn(ji,jj,jk,jp_sal) * e3t_n(ji,jj,jk) * tmask (ji,jj,jk) & + - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk) + + ! shh changes + IF ( ptmask_b(ji,jj,jk) == 1._wp .OR. tmask(ji,jj,jk) == 1._wp ) THEN + zde3t = zde3t + zdssh(ji,jj) ! zdssh = 0 if vvl + zdssh(ji,jj) = 0._wp + END IF + + ! volume, heat and salt differences in each cell + pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t * z1_rdtiscpl + pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal * z1_rdtiscpl + pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem * z1_rdtiscpl + + ! case where we close a cell: check if the neighbour cells are wet + IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN + + jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ; + + zsum = e1e2t(ji ,jjp1) * tmask(ji ,jjp1,jk) + e1e2t(ji ,jjm1) * tmask(ji ,jjm1,jk) & + & + e1e2t(jim1,jj ) * tmask(jim1,jj ,jk) + e1e2t(jip1,jj ) * tmask(jip1,jj ,jk) + + IF ( zsum /= 0._wp ) THEN + zjip1_ratio = e1e2t(jip1,jj ) * tmask(jip1,jj ,jk) / zsum + zjim1_ratio = e1e2t(jim1,jj ) * tmask(jim1,jj ,jk) / zsum + zjjp1_ratio = e1e2t(ji ,jjp1) * tmask(ji ,jjp1,jk) / zsum + zjjm1_ratio = e1e2t(ji ,jjm1) * tmask(ji ,jjm1,jk) / zsum + + pvol_flx(ji ,jjp1,jk ) = pvol_flx(ji ,jjp1,jk ) + pvol_flx(ji,jj,jk ) * zjjp1_ratio + pvol_flx(ji ,jjm1,jk ) = pvol_flx(ji ,jjm1,jk ) + pvol_flx(ji,jj,jk ) * zjjm1_ratio + pvol_flx(jip1,jj ,jk ) = pvol_flx(jip1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjip1_ratio + pvol_flx(jim1,jj ,jk ) = pvol_flx(jim1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjim1_ratio + pts_flx (ji ,jjp1,jk,jp_sal) = pts_flx (ji ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio + pts_flx (ji ,jjm1,jk,jp_sal) = pts_flx (ji ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio + pts_flx (jip1,jj ,jk,jp_sal) = pts_flx (jip1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio + pts_flx (jim1,jj ,jk,jp_sal) = pts_flx (jim1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio + pts_flx (ji ,jjp1,jk,jp_tem) = pts_flx (ji ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio + pts_flx (ji ,jjm1,jk,jp_tem) = pts_flx (ji ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio + pts_flx (jip1,jj ,jk,jp_tem) = pts_flx (jip1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio + pts_flx (jim1,jj ,jk,jp_tem) = pts_flx (jim1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio + + ! set to 0 the cell we distributed over neigbourg cells + pvol_flx(ji,jj,jk ) = 0._wp + pts_flx (ji,jj,jk,jp_sal) = 0._wp + pts_flx (ji,jj,jk,jp_tem) = 0._wp + + ELSE IF (zsum == 0._wp ) THEN + ! case where we close a cell and no adjacent cell open + ! check if the cell beneath is wet + IF ( tmask(ji,jj,jk+1) == 1._wp ) THEN + pvol_flx(ji,jj,jk+1) = pvol_flx(ji,jj,jk+1) + pvol_flx(ji,jj,jk) + pts_flx (ji,jj,jk+1,jp_sal)= pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal) + pts_flx (ji,jj,jk+1,jp_tem)= pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem) + + ! set to 0 the cell we distributed over neigbourg cells + pvol_flx(ji,jj,jk ) = 0._wp + pts_flx (ji,jj,jk,jp_sal) = 0._wp + pts_flx (ji,jj,jk,jp_tem) = 0._wp + ELSE + ! case no adjacent cell on the horizontal and on the vertical + IF ( lwp ) THEN ! JMM : cAution this warning may occur on any mpp subdomain but numout is only + ! open for narea== 1 (lwp=T) + WRITE(numout,*) 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal' + WRITE(numout,*) ' ',mig(ji),' ',mjg(jj),' ',jk + WRITE(numout,*) ' ',ji,' ',jj,' ',jk,' ',narea + WRITE(numout,*) ' we are now looking for the closest wet cell on the horizontal ' + ENDIF + ! We deal with these points later. + END IF + END IF + END IF + END IF + END DO + END DO + END DO + +!!gm ERROR !!!! +!! juste use tmask_i or in case of ISF smask_i (to be created to compute the sum without halos) +! +! CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) +! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) +! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) + CALL ctl_stop( 'STOP', ' iscpl_cons: please modify this MODULE !' ) +!!gm end + ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point + ! allocation and initialisation of the list of problematic point + ALLOCATE( inpts(jpnij) ) + inpts(:) = 0 + + ! fill narea location with the number of problematic point + DO jk = 1,jpk-1 + DO jj = 2,jpj-1 + DO ji = fs_2,fs_jpim1 + IF ( ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1) == 0._wp .AND. tmask_h(ji,jj) == 1._wp & + .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN + inpts(narea) = inpts(narea) + 1 + END IF + END DO + END DO + END DO + + ! build array of total problematic point on each cpu (share to each cpu) + CALL mpp_max('iscplhsb', inpts,jpnij) + + ! size of the new variable + npts = SUM(inpts) + + ! allocation of the coordinates, correction, index vector for the problematic points + ALLOCATE(ixpts(npts), iypts(npts), izpts(npts), zcorr_vol(npts), zcorr_sal(npts), zcorr_tem(npts), zlon(npts), zlat(npts)) + ixpts(:) = -9999 ; iypts(:) = -9999 ; izpts(:) = -9999 ; zlon(:) = -1.0e20_wp ; zlat(:) = -1.0e20_wp + zcorr_vol(:) = -1.0e20_wp + zcorr_sal(:) = -1.0e20_wp + zcorr_tem(:) = -1.0e20_wp + + ! fill new variable + jpts = SUM(inpts(1:narea-1)) + DO jk = 1,jpk-1 + DO jj = 2,jpj-1 + DO ji = fs_2,fs_jpim1 + IF ( ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1) == 0._wp .AND. tmask_h(ji,jj) == 1._wp & + .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN + jpts = jpts + 1 ! positioning in the inpts vector for the area narea + ixpts(jpts) = ji ; iypts(jpts) = jj ; izpts(jpts) = jk + zlon (jpts) = glamt(ji,jj) ; zlat (jpts) = gphit(ji,jj) + zcorr_vol(jpts) = pvol_flx(ji,jj,jk) + zcorr_sal(jpts) = pts_flx (ji,jj,jk,jp_sal) + zcorr_tem(jpts) = pts_flx (ji,jj,jk,jp_tem) + + ! set flx to 0 (safer) + pvol_flx(ji,jj,jk ) = 0.0_wp + pts_flx (ji,jj,jk,jp_sal) = 0.0_wp + pts_flx (ji,jj,jk,jp_tem) = 0.0_wp + END IF + END DO + END DO + END DO + + ! build array of total problematic point on each cpu (share to each cpu) + ! point coordinates + CALL mpp_max('iscplhsb', zlat ,npts) + CALL mpp_max('iscplhsb', zlon ,npts) + CALL mpp_max('iscplhsb', izpts,npts) + + ! correction values + CALL mpp_max('iscplhsb', zcorr_vol,npts) + CALL mpp_max('iscplhsb', zcorr_sal,npts) + CALL mpp_max('iscplhsb', zcorr_tem,npts) + + ! put correction term in the closest cell + DO jpts = 1,npts + CALL dom_ngb(zlon(jpts), zlat(jpts), ixpts(jpts), iypts(jpts),'T', izpts(jpts)) + DO jj = mj0(iypts(jpts)),mj1(iypts(jpts)) + DO ji = mi0(ixpts(jpts)),mi1(ixpts(jpts)) + jk = izpts(jpts) + + IF (tmask_h(ji,jj) == 1._wp) THEN + ! correct the vol_flx in the closest cell + pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk ) + zcorr_vol(jpts) + pts_flx (ji,jj,jk,jp_sal) = pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts) + pts_flx (ji,jj,jk,jp_tem) = pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts) + + ! set correction to 0 + zcorr_vol(jpts) = 0.0_wp + zcorr_sal(jpts) = 0.0_wp + zcorr_tem(jpts) = 0.0_wp + END IF + END DO + END DO + END DO + + ! deallocate variables + DEALLOCATE(inpts) + DEALLOCATE(ixpts, iypts, izpts, zcorr_vol, zcorr_sal, zcorr_tem, zlon, zlat) + + ! add contribution store on the hallo (lbclnk remove one of the contribution) + pvol_flx(:,:,: ) = pvol_flx(:,:,: ) * tmask(:,:,:) + pts_flx (:,:,:,jp_sal) = pts_flx (:,:,:,jp_sal) * tmask(:,:,:) + pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) + +!!gm ERROR !!!! +!! juste use tmask_i or in case of ISF smask_i (to be created to compute the sum without halos) +! +! ! compute sum over the halo and set it to 0. +! CALL lbc_sum(pvol_flx(:,:,: ),'T',1._wp) +! CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) +! CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) +!!gm end + + ! + END SUBROUTINE iscpl_cons + + + SUBROUTINE iscpl_div( phdivn ) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_div *** + !! + !! ** Purpose : update the horizontal divergenc + !! + !! ** Method : + !! CAUTION : iscpl is positive (inflow) and expressed in m/s + !! + !! ** Action : phdivn increase by the iscpl correction term + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: phdivn ! horizontal divergence + !! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + hdiv_iscpl(ji,jj,jk) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! + END SUBROUTINE iscpl_div + +END MODULE iscplhsb diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/iscplini.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/iscplini.F90 new file mode 100644 index 0000000..2b201fa --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/iscplini.F90 @@ -0,0 +1,90 @@ +MODULE iscplini + !!====================================================================== + !! *** MODULE sbciscpl *** + !! Ocean forcing: ????? + !!===================================================================== + !! History : NEMO ! 2015-01 P. Mathiot: original + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iscpl_init : initialisation routine (namelist) + !! iscpl_alloc : allocation of correction variables + !!---------------------------------------------------------------------- + USE oce ! global tra/dyn variable + USE dom_oce ! ocean space and time domain + ! + USE lib_mpp ! MPP library + USE lib_fortran ! MPP library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC iscpl_init + PUBLIC iscpl_alloc + + ! !!* namsbc_iscpl namelist * + LOGICAL , PUBLIC :: ln_hsb !: + INTEGER , PUBLIC :: nn_fiscpl !: + INTEGER , PUBLIC :: nn_drown !: + + INTEGER , PUBLIC :: nstp_iscpl !: + REAL(wp), PUBLIC :: rdt_iscpl !: + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdiv_iscpl !: + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: htsc_iscpl !: + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION iscpl_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_iscpl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( htsc_iscpl(jpi,jpj,jpk,jpts) , hdiv_iscpl(jpi,jpj,jpk) , STAT=iscpl_alloc ) + ! + CALL mpp_sum ( 'iscplini', iscpl_alloc ) + IF( iscpl_alloc > 0 ) CALL ctl_warn('iscpl_alloc: allocation of arrays failed') + END FUNCTION iscpl_alloc + + + SUBROUTINE iscpl_init() + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + INTEGER :: ios ! Local integer output status for namelist read + NAMELIST/namsbc_iscpl/ nn_fiscpl, ln_hsb, nn_drown + !!---------------------------------------------------------------------- + ! + nn_fiscpl = 0 + ln_hsb = .FALSE. + REWIND( numnam_ref ) ! Namelist namsbc_iscpl in reference namelist : Ice sheet coupling + READ ( numnam_ref, namsbc_iscpl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namsbc_iscpl in configuration namelist : Ice Sheet coupling + READ ( numnam_cfg, namsbc_iscpl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_iscpl in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_iscpl ) + ! + nstp_iscpl=MIN( nn_fiscpl, nitend-nit000+1 ) ! the coupling period have to be less or egal than the total number of time step + rdt_iscpl = nstp_iscpl * rn_rdt + ! + IF (lwp) THEN + WRITE(numout,*) 'iscpl_rst:' + WRITE(numout,*) '~~~~~~~~~' + WRITE(numout,*) ' coupling flag (ln_iscpl ) = ', ln_iscpl + WRITE(numout,*) ' conservation flag (ln_hsb ) = ', ln_hsb + WRITE(numout,*) ' nb of stp for cons (rn_fiscpl) = ', nstp_iscpl + IF (nstp_iscpl .NE. nn_fiscpl) WRITE(numout,*) 'W A R N I N G: nb of stp for cons has been modified & + & (larger than run length)' + WRITE(numout,*) ' coupling time step = ', rdt_iscpl + WRITE(numout,*) ' number of call of the extrapolation loop = ', nn_drown + ENDIF + ! + END SUBROUTINE iscpl_init + + !!====================================================================== +END MODULE iscplini diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/iscplrst.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/iscplrst.F90 new file mode 100644 index 0000000..d9c9bdf --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/iscplrst.F90 @@ -0,0 +1,407 @@ +MODULE iscplrst + !!====================================================================== + !! *** MODULE iscplrst *** + !! Ocean forcing: update the restart file in case of ice sheet/ocean coupling + !!===================================================================== + !! History : NEMO ! 2015-01 P. Mathiot: original + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! iscpl_stp : step management + !! iscpl_rst_interpol : restart interpolation in case of coupling with ice sheet + !!---------------------------------------------------------------------- + USE oce ! global tra/dyn variable + USE dom_oce ! ocean space and time domain + USE domwri ! ocean space and time domain + USE domvvl , ONLY : dom_vvl_interpol + USE phycst ! physical constants + USE sbc_oce ! surface boundary condition variables + USE iscplini ! ice sheet coupling: initialisation + USE iscplhsb ! ice sheet coupling: conservation + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE lib_mpp ! MPP library + USE lib_fortran ! MPP library + USE lbclnk ! communication + + IMPLICIT NONE + PRIVATE + + PUBLIC iscpl_stp ! step management + !! + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iscpl_stp + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_stp *** + !! + !! ** Purpose : compute initialisation + !! compute extrapolation of restart variable un, vn, tsn, sshn (wetting/drying) + !! compute correction term if needed + !! + !!---------------------------------------------------------------------- + INTEGER :: inum0 + REAL(wp), DIMENSION(jpi,jpj) :: zsmask_b + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask_b, zumask_b, zvmask_b + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ze3t_b , ze3u_b , ze3v_b + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdepw_b + CHARACTER(20) :: cfile + !!---------------------------------------------------------------------- + ! + ! ! get restart variable + CALL iom_get( numror, jpdom_autoglo, 'tmask' , ztmask_b, ldxios = lrxios ) ! need to extrapolate T/S + CALL iom_get( numror, jpdom_autoglo, 'umask' , zumask_b, ldxios = lrxios ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'vmask' , zvmask_b, ldxios = lrxios ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'smask' , zsmask_b, ldxios = lrxios ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'e3t_n' , ze3t_b(:,:,:), ldxios = lrxios ) ! need to compute temperature correction + CALL iom_get( numror, jpdom_autoglo, 'e3u_n' , ze3u_b(:,:,:), ldxios = lrxios ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'e3v_n' , ze3v_b(:,:,:), ldxios = lrxios ) ! need to correct barotropic velocity + CALL iom_get( numror, jpdom_autoglo, 'gdepw_n', zdepw_b(:,:,:), ldxios = lrxios ) ! need to interpol vertical profile (vvl) + ! + CALL iscpl_init() ! read namelist + ! ! Extrapolation/interpolation of modify cell and new cells ... (maybe do it later after domvvl) + CALL iscpl_rst_interpol( ztmask_b, zumask_b, zvmask_b, zsmask_b, ze3t_b, ze3u_b, ze3v_b, zdepw_b ) + ! + IF ( ln_hsb ) THEN ! compute correction if conservation needed + IF( iscpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'rst_iscpl : unable to allocate rst_iscpl arrays' ) + CALL iscpl_cons(ztmask_b, zsmask_b, ze3t_b, htsc_iscpl, hdiv_iscpl, rdt_iscpl) + END IF + + ! ! create a domain file + IF( ln_meshmask .AND. ln_iscpl ) CALL dom_wri + ! + IF ( ln_hsb ) THEN + cfile='correction' + cfile = TRIM( cfile ) + CALL iom_open ( cfile, inum0, ldwrt = .TRUE. ) + CALL iom_rstput( 0, 0, inum0, 'vol_cor', hdiv_iscpl(:,:,:) ) + CALL iom_rstput( 0, 0, inum0, 'tem_cor', htsc_iscpl(:,:,:,jp_tem) ) + CALL iom_rstput( 0, 0, inum0, 'sal_cor', htsc_iscpl(:,:,:,jp_sal) ) + CALL iom_close ( inum0 ) + END IF + ! + neuler = 0 ! next step is an euler time step + ! + ! ! set _b and _n variables equal + tsb (:,:,:,:) = tsn (:,:,:,:) + ub (:,:,:) = un (:,:,:) + vb (:,:,:) = vn (:,:,:) + sshb(:,:) = sshn(:,:) + ! + ! ! set _b and _n vertical scale factor equal + e3t_b (:,:,:) = e3t_n (:,:,:) + e3u_b (:,:,:) = e3u_n (:,:,:) + e3v_b (:,:,:) = e3v_n (:,:,:) + ! + e3uw_b (:,:,:) = e3uw_n (:,:,:) + e3vw_b (:,:,:) = e3vw_n (:,:,:) + gdept_b(:,:,:) = gdept_n(:,:,:) + gdepw_b(:,:,:) = gdepw_n(:,:,:) + hu_b (:,:) = hu_n (:,:) + hv_b (:,:) = hv_n (:,:) + r1_hu_b(:,:) = r1_hu_n(:,:) + r1_hv_b(:,:) = r1_hv_n(:,:) + ! + END SUBROUTINE iscpl_stp + + + SUBROUTINE iscpl_rst_interpol (ptmask_b, pumask_b, pvmask_b, psmask_b, pe3t_b, pe3u_b, pe3v_b, pdepw_b) + !!---------------------------------------------------------------------- + !! *** ROUTINE iscpl_rst_interpol *** + !! + !! ** Purpose : compute new tn, sn, un, vn and sshn in case of evolving geometry of ice shelves + !! compute 2d fields of heat, salt and volume correction + !! + !! ** Method : tn, sn : extrapolation from neigbourg cells + !! un, vn : fill with 0 velocity and keep barotropic transport by modifing surface velocity or adjacent velocity + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: ptmask_b, pumask_b, pvmask_b !! mask before + REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pe3t_b , pe3u_b , pe3v_b !! scale factor before + REAL(wp), DIMENSION(:,:,: ), INTENT(in ) :: pdepw_b !! depth w before + REAL(wp), DIMENSION(:,: ), INTENT(in ) :: psmask_b !! mask before + !! + INTEGER :: ji, jj, jk, iz !! loop index + INTEGER :: jip1, jim1, jjp1, jjm1, jkp1, jkm1 + !! + REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb + REAL(wp):: zdz, zdzm1, zdzp1 + !! + REAL(wp), DIMENSION(jpi,jpj) :: zdmask , zsmask0, zucorr, zbub, zbun, zssh0, zhu1, zde3t + REAL(wp), DIMENSION(jpi,jpj) :: zdsmask, zsmask1, zvcorr, zbvb, zbvn, zssh1, zhv1 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask0, zwmaskn, ztrp + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztmask1, zwmaskb, ztmp3d + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts0 + !!---------------------------------------------------------------------- + ! + ! ! mask value to be sure + tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * ptmask_b(:,:,:) + tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * ptmask_b(:,:,:) + ! + ! ! compute wmask + zwmaskn(:,:,1) = tmask (:,:,1) + zwmaskb(:,:,1) = ptmask_b(:,:,1) + DO jk = 2,jpk + zwmaskn(:,:,jk) = tmask (:,:,jk) * tmask (:,:,jk-1) + zwmaskb(:,:,jk) = ptmask_b(:,:,jk) * ptmask_b(:,:,jk-1) + END DO + ! + ! ! compute new ssh if we open a full water column (average of the closest neigbourgs) + sshb (:,:)=sshn(:,:) + zssh0(:,:)=sshn(:,:) + zsmask0(:,:) = psmask_b(:,:) + zsmask1(:,:) = psmask_b(:,:) + DO iz = 1, 10 ! need to be tuned (configuration dependent) (OK for ISOMIP+) + zdsmask(:,:) = ssmask(:,:)-zsmask0(:,:) + DO jj = 2,jpj-1 + DO ji = fs_2, fs_jpim1 ! vector opt. + jip1=ji+1; jim1=ji-1; + jjp1=jj+1; jjm1=jj-1; + summsk=(zsmask0(jip1,jj)+zsmask0(jim1,jj)+zsmask0(ji,jjp1)+zsmask0(ji,jjm1)) + IF (zdsmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN + sshn(ji,jj)=( zssh0(jip1,jj)*zsmask0(jip1,jj) & + & + zssh0(jim1,jj)*zsmask0(jim1,jj) & + & + zssh0(ji,jjp1)*zsmask0(ji,jjp1) & + & + zssh0(ji,jjm1)*zsmask0(ji,jjm1))/summsk + zsmask1(ji,jj)=1._wp + ENDIF + END DO + END DO + CALL lbc_lnk_multi( 'iscplrst', sshn, 'T', 1., zsmask1, 'T', 1. ) + zssh0 = sshn + zsmask0 = zsmask1 + END DO + sshn(:,:) = sshn(:,:) * ssmask(:,:) + +!============================================================================= +!PM: Is this needed since introduction of VVL by default? + IF ( .NOT.ln_linssh ) THEN + ! Reconstruction of all vertical scale factors at now time steps + ! ============================================================================= + ! Horizontal scale factor interpolations + ! -------------------------------------- + DO jk = 1,jpk + DO jj=1,jpj + DO ji=1,jpi + IF (tmask(ji,jj,1) == 0._wp .OR. ptmask_b(ji,jj,1) == 0._wp) THEN + e3t_n(ji,jj,jk) = e3t_0(ji,jj,jk) * ( 1._wp + sshn(ji,jj) / & + & ( ht_0(ji,jj) + 1._wp - ssmask(ji,jj) ) * tmask(ji,jj,jk) ) + ENDIF + END DO + END DO + END DO + ! + CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) + + ! Vertical scale factor interpolations + ! ------------------------------------ + CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) + + ! t- and w- points depth + ! ---------------------- + gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) + gdepw_n(:,:,1) = 0.0_wp + gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:) + DO jj = 1,jpj + DO ji = 1,jpi + DO jk = 2,mikt(ji,jj)-1 + gdept_n(ji,jj,jk) = gdept_0(ji,jj,jk) + gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + gde3w_n(ji,jj,jk) = gdept_0(ji,jj,jk) - sshn(ji,jj) + END DO + IF (mikt(ji,jj) > 1) THEN + jk = mikt(ji,jj) + gdept_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + 0.5_wp * e3w_n(ji,jj,jk) + gdepw_n(ji,jj,jk) = gdepw_0(ji,jj,jk) + gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk ) - sshn (ji,jj) + END IF + DO jk = mikt(ji,jj)+1, jpk + gdept_n(ji,jj,jk) = gdept_n(ji,jj,jk-1) + e3w_n(ji,jj,jk) + gdepw_n(ji,jj,jk) = gdepw_n(ji,jj,jk-1) + e3t_n(ji,jj,jk-1) + gde3w_n(ji,jj,jk) = gdept_n(ji,jj,jk ) - sshn (ji,jj) + END DO + END DO + END DO + + ! t-, u- and v- water column thickness + ! ------------------------------------ + ht_n(:,:) = 0._wp ; hu_n(:,:) = 0._wp ; hv_n(:,:) = 0._wp + DO jk = 1, jpkm1 + hu_n(:,:) = hu_n(:,:) + e3u_n(:,:,jk) * umask(:,:,jk) + hv_n(:,:) = hv_n(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk) + ht_n(:,:) = ht_n(:,:) + e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + ! ! Inverse of the local depth + r1_hu_n(:,:) = 1._wp / ( hu_n(:,:) + 1._wp - ssumask(:,:) ) * ssumask(:,:) + r1_hv_n(:,:) = 1._wp / ( hv_n(:,:) + 1._wp - ssvmask(:,:) ) * ssvmask(:,:) + + END IF + +!============================================================================= +! compute velocity +! compute velocity in order to conserve barotropic velocity (modification by poderation of the scale factor). + ub(:,:,:)=un(:,:,:) + vb(:,:,:)=vn(:,:,:) + DO jk = 1,jpk + DO jj = 1,jpj + DO ji = 1,jpi + un(ji,jj,jk) = ub(ji,jj,jk)*pe3u_b(ji,jj,jk)*pumask_b(ji,jj,jk)/e3u_n(ji,jj,jk)*umask(ji,jj,jk); + vn(ji,jj,jk) = vb(ji,jj,jk)*pe3v_b(ji,jj,jk)*pvmask_b(ji,jj,jk)/e3v_n(ji,jj,jk)*vmask(ji,jj,jk); + END DO + END DO + END DO + +! compute new velocity if we close a cell (check barotropic velocity and change velocity over the water column) +! compute barotropic velocity now and after + ztrp(:,:,:) = ub(:,:,:)*pe3u_b(:,:,:); + zbub(:,:) = SUM(ztrp,DIM=3) + ztrp(:,:,:) = vb(:,:,:)*pe3v_b(:,:,:); + zbvb(:,:) = SUM(ztrp,DIM=3) + ztrp(:,:,:) = un(:,:,:)*e3u_n(:,:,:); + zbun(:,:) = SUM(ztrp,DIM=3) + ztrp(:,:,:) = vn(:,:,:)*e3v_n(:,:,:); + zbvn(:,:) = SUM(ztrp,DIM=3) + + ! new water column + zhu1=0.0_wp ; + zhv1=0.0_wp ; + DO jk = 1,jpk + zhu1(:,:) = zhu1(:,:) + e3u_n(:,:,jk) * umask(:,:,jk) + zhv1(:,:) = zhv1(:,:) + e3v_n(:,:,jk) * vmask(:,:,jk) + END DO + + ! compute correction + zucorr = 0._wp + zvcorr = 0._wp + DO jj = 1,jpj + DO ji = 1,jpi + IF (zbun(ji,jj) /= zbub(ji,jj) .AND. zhu1(ji,jj) /= 0._wp ) THEN + zucorr(ji,jj) = (zbun(ji,jj) - zbub(ji,jj))/zhu1(ji,jj) + END IF + IF (zbvn(ji,jj) /= zbvb(ji,jj) .AND. zhv1(ji,jj) /= 0._wp ) THEN + zvcorr(ji,jj) = (zbvn(ji,jj) - zbvb(ji,jj))/zhv1(ji,jj) + END IF + END DO + END DO + + ! update velocity + DO jk = 1,jpk + un(:,:,jk)=(un(:,:,jk) - zucorr(:,:))*umask(:,:,jk) + vn(:,:,jk)=(vn(:,:,jk) - zvcorr(:,:))*vmask(:,:,jk) + END DO + +!============================================================================= + ! compute temp and salt + ! compute new tn and sn if we open a new cell + tsb (:,:,:,:) = tsn(:,:,:,:) + zts0(:,:,:,:) = tsn(:,:,:,:) + ztmask1(:,:,:) = ptmask_b(:,:,:) + ztmask0(:,:,:) = ptmask_b(:,:,:) + DO iz = 1,nn_drown ! resolution dependent (OK for ISOMIP+ case) + DO jk = 1,jpk-1 + zdmask=tmask(:,:,jk)-ztmask0(:,:,jk); + DO jj = 2,jpj-1 + DO ji = fs_2,fs_jpim1 + jip1=ji+1; jim1=ji-1; + jjp1=jj+1; jjm1=jj-1; + summsk= (ztmask0(jip1,jj ,jk)+ztmask0(jim1,jj ,jk)+ztmask0(ji ,jjp1,jk)+ztmask0(ji ,jjm1,jk)) + IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp) THEN + !! horizontal basic extrapolation + tsn(ji,jj,jk,1)=( 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) ) / summsk + tsn(ji,jj,jk,2)=( 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) ) / summsk + ztmask1(ji,jj,jk)=1 + ELSEIF (zdmask(ji,jj) == 1._wp .AND. summsk == 0._wp) THEN + !! vertical extrapolation if horizontal extrapolation failed + jkm1=max(1,jk-1) ; jkp1=min(jpk,jk+1) + summsk=(ztmask0(ji,jj,jkm1)+ztmask0(ji,jj,jkp1)) + IF (zdmask(ji,jj) == 1._wp .AND. summsk /= 0._wp ) THEN + tsn(ji,jj,jk,1)=( zts0(ji,jj,jkp1,1)*ztmask0(ji,jj,jkp1) & + & +zts0(ji,jj,jkm1,1)*ztmask0(ji,jj,jkm1))/summsk + tsn(ji,jj,jk,2)=( zts0(ji,jj,jkp1,2)*ztmask0(ji,jj,jkp1) & + & +zts0(ji,jj,jkm1,2)*ztmask0(ji,jj,jkm1))/summsk + ztmask1(ji,jj,jk)=1._wp + END IF + END IF + END DO + END DO + END DO + + CALL lbc_lnk_multi( 'iscplrst', tsn(:,:,:,jp_tem), 'T', 1., tsn(:,:,:,jp_sal), 'T', 1., ztmask1, 'T', 1.) + + ! update + zts0(:,:,:,:) = tsn(:,:,:,:) + ztmask0 = ztmask1 + + END DO + + ! mask new tsn field + tsn(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) * tmask(:,:,:) + tsn(:,:,:,jp_sal) = tsn(:,:,:,jp_sal) * tmask(:,:,:) + + ! 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 + IF (.NOT.ln_linssh) THEN + DO jk = 2,jpk-1 + DO jj = 1,jpj + DO ji = 1,jpi + IF (zwmaskn(ji,jj,jk) * zwmaskb(ji,jj,jk) == 1._wp .AND. & + & (tmask(ji,jj,1)==0._wp .OR. ptmask_b(ji,jj,1)==0._wp) ) THEN + !compute weight + zdzp1 = MAX(0._wp,gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk+1)) + zdz = gdepw_n(ji,jj,jk+1) - pdepw_b(ji,jj,jk ) + zdzm1 = MAX(0._wp,pdepw_b(ji,jj,jk ) - gdepw_n(ji,jj,jk )) + IF (zdz .LT. 0._wp) THEN + CALL ctl_stop( 'STOP', 'rst_iscpl : unable to compute the interpolation' ) + END IF + tsn(ji,jj,jk,jp_tem) = ( zdzp1*tsb(ji,jj,jk+1,jp_tem) & + & + zdz *tsb(ji,jj,jk ,jp_tem) & + & + zdzm1*tsb(ji,jj,jk-1,jp_tem) )/e3t_n(ji,jj,jk) + tsn(ji,jj,jk,jp_sal) = ( zdzp1*tsb(ji,jj,jk+1,jp_sal) & + & + zdz *tsb(ji,jj,jk ,jp_sal) & + & + zdzm1*tsb(ji,jj,jk-1,jp_sal) )/e3t_n(ji,jj,jk) + END IF + END DO + END DO + END DO + END IF + + ! closed pool + ! ----------------------------------------------------------------------------------------- + ! case we open a cell but no neigbour cells available to get an estimate of T and S + WHERE (tmask(:,:,:) == 1._wp .AND. tsn(:,:,:,2) == 0._wp) + tsn(:,:,:,2) = -99._wp ! Special value for closed pool (checking purpose in output.init) + tmask(:,:,:) = 0._wp ! set mask to 0 to run + umask(:,:,:) = 0._wp + vmask(:,:,:) = 0._wp + END WHERE + + ! set mbkt and mikt to 1 in thiese location + WHERE (SUM(tmask,dim=3) == 0) + mbkt(:,:)=1 ; mbku(:,:)=1 ; mbkv(:,:)=1 + mikt(:,:)=1 ; miku(:,:)=1 ; mikv(:,:)=1 + END WHERE + ! ------------------------------------------------------------------------------------------- + ! compute new tn and sn if we close cell + ! nothing to do + ! + END SUBROUTINE iscpl_rst_interpol + + !!====================================================================== +END MODULE iscplrst diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/istate.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/istate.F90 new file mode 100644 index 0000000..d820d93 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/istate.F90 @@ -0,0 +1,186 @@ +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 iscplrst ! ice sheet coupling + 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 restart ! restart + + IMPLICIT NONE + PRIVATE + + PUBLIC istate_init ! routine called by step.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE istate_init + !!---------------------------------------------------------------------- + !! *** ROUTINE istate_init *** + !! + !! ** Purpose : Initialization of the dynamics and tracer fields. + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices +!!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,*) '~~~~~~~~~~~' + +!!gm Why not include in the first call of dta_tsd ? +!!gm probably associated with the use of internal damping... + CALL dta_tsd_init ! Initialisation of T & S input data +!!gm to be moved in usrdef of C1D case +! IF( lk_c1d ) CALL dta_uvd_init ! Initialization of U & V input data +!!gm + + rhd (:,:,: ) = 0._wp ; rhop (:,:,: ) = 0._wp ! set one for all to 0 at level jpk + rn2b (:,:,: ) = 0._wp ; rn2 (:,:,: ) = 0._wp ! set one for all to 0 at levels 1 and jpk + tsa (:,:,:,:) = 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 +#if defined key_agrif + ua (:,:,: ) = 0._wp ! used in agrif_oce_sponge at initialization + va (:,:,: ) = 0._wp ! used in agrif_oce_sponge at initialization +#endif + + IF( ln_rstart ) THEN ! Restart from a file + ! ! ------------------- + CALL rst_read ! Read the restart file + IF (ln_iscpl) CALL iscpl_stp ! extrapolate restart to wet and dry + 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 + neuler = 0 ! 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_2d) THEN + IF(lwp) WRITE(numout,*) 'istate_init : 2D case, setting tracers to contants and ocean at rest' + tsb(:,:,:,:)= 15._wp ! No tracers, but can't set salinity to 0 otherwise it triggers crash message + sshb(:,:) = 0._wp ! set the ocean at rest + ub (:,:,:) = 0._wp + vb (:,:,:) = 0._wp + ELSE IF( ln_tsd_init ) THEN + CALL dta_tsd( nit000, tsb ) ! read 3D T and S data at nit000 + ! + sshb(:,:) = 0._wp ! set the ocean at rest + IF( ll_wd ) THEN + sshb(:,:) = -ssh_ref ! Added in 30 here for bathy that adds 30 as Iterative test CEOD + ! + ! Apply minimum wetdepth criterion + ! + DO jj = 1,jpj + DO ji = 1,jpi + IF( ht_0(ji,jj) + sshb(ji,jj) < rn_wdmin1 ) THEN + sshb(ji,jj) = tmask(ji,jj,1)*( rn_wdmin1 - (ht_0(ji,jj)) ) + ENDIF + END DO + END DO + ENDIF + ub (:,:,:) = 0._wp + vb (:,:,:) = 0._wp + ! + ELSE ! user defined initial T and S + CALL usr_def_istate( gdept_b, tmask, tsb, ub, vb, sshb ) + ENDIF + tsn (:,:,:,:) = tsb (:,:,:,:) ! set now values from to before ones + sshn (:,:) = sshb(:,:) + un (:,:,:) = ub (:,:,:) + vn (:,:,:) = vb (:,:,:) + +!!gm POTENTIAL BUG : +!!gm ISSUE : if sshb /= 0 then, in non linear free surface, the e3._n, e3._b should be recomputed +!! as well as gdept and gdepw.... !!!!! +!! ===>>>> probably a call to domvvl initialisation here.... + + + ! +!!gm to be moved in usrdef of C1D case +! IF ( ln_uvd_init .AND. lk_c1d ) THEN ! read 3D U and V data at nit000 +! ALLOCATE( zuvd(jpi,jpj,jpk,2) ) +! CALL dta_uvd( nit000, zuvd ) +! ub(:,:,:) = zuvd(:,:,:,1) ; un(:,:,:) = ub(:,:,:) +! vb(:,:,:) = zuvd(:,:,:,2) ; vn(:,:,:) = vb(:,:,:) +! DEALLOCATE( zuvd ) +! ENDIF + ! +!!gm This is to be changed !!!! +! ! - ML - sshn could be modified by istate_eel, so that initialization of e3t_b is done here +! IF( .NOT.ln_linssh ) THEN +! DO jk = 1, jpk +! e3t_b(:,:,jk) = e3t_n(:,:,jk) +! END DO +! ENDIF +!!gm + ! + ENDIF + ! + ! Initialize "now" and "before" barotropic velocities: + ! Do it whatever the free surface method, these arrays being eventually used + ! + un_b(:,:) = 0._wp ; vn_b(:,:) = 0._wp + ub_b(:,:) = 0._wp ; vb_b(:,:) = 0._wp + ! +!!gm the use of umsak & vmask is not necessary below as un, vn, ub, vb are always masked + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + un_b(ji,jj) = un_b(ji,jj) + e3u_n(ji,jj,jk) * un(ji,jj,jk) * umask(ji,jj,jk) + vn_b(ji,jj) = vn_b(ji,jj) + e3v_n(ji,jj,jk) * vn(ji,jj,jk) * vmask(ji,jj,jk) + ! + ub_b(ji,jj) = ub_b(ji,jj) + e3u_b(ji,jj,jk) * ub(ji,jj,jk) * umask(ji,jj,jk) + vb_b(ji,jj) = vb_b(ji,jj) + e3v_b(ji,jj,jk) * vb(ji,jj,jk) * vmask(ji,jj,jk) + END DO + END DO + END DO + ! + un_b(:,:) = un_b(:,:) * r1_hu_n(:,:) + vn_b(:,:) = vn_b(:,:) * r1_hv_n(:,:) + ! + ub_b(:,:) = ub_b(:,:) * r1_hu_b(:,:) + vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:) + ! + END SUBROUTINE istate_init + + !!====================================================================== +END MODULE istate diff --git a/NEMO_4.0.4_surge/src/OCE/DOM/phycst.F90 b/NEMO_4.0.4_surge/src/OCE/DOM/phycst.F90 new file mode 100644 index 0000000..9aaa785 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DOM/phycst.F90 @@ -0,0 +1,139 @@ +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 :: rau0 !: volumic mass of reference [kg/m3] + REAL(wp), PUBLIC :: r1_rau0 !: = 1. / rau0 [m3/kg] + REAL(wp), PUBLIC :: rcp !: ocean specific heat [J/Kelvin] + REAL(wp), PUBLIC :: r1_rcp !: = 1. / rcp [Kelvin/J] + REAL(wp), PUBLIC :: rau0_rcp !: = rau0 * rcp + REAL(wp), PUBLIC :: r1_rau0_rcp !: = 1. / ( rau0 * 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 :: 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$ + !! 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 ) +#if defined key_cice + omega = 7.292116e-05 +#else + omega = 2._wp * rpi / rsiday +#endif + + 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/NEMO_4.0.4_surge/src/OCE/DYN/divhor.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/divhor.F90 new file mode 100644 index 0000000..081c3e9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/divhor.F90 @@ -0,0 +1,114 @@ +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, ln_isf ! surface boundary condition: ocean + USE sbcrnf ! river runoff + USE sbcisf ! ice shelf + USE iscplhsb ! ice sheet / ocean coupling + USE iscplini ! ice sheet / ocean coupling +#if defined key_asminc + USE asminc ! Assimilation increment +#endif + ! + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE div_hor( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE div_hor *** + !! + !! ** Purpose : compute the horizontal divergence at now time-step + !! + !! ** Method : the now divergence is computed as : + !! hdivn = 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 hdivn, the now horizontal divergence + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zraur, zdep ! local scalars + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('div_hor') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'div_hor : horizontal velocity divergence ' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + hdivn(:,:,:) = 0._wp ! initialize hdivn for the halos at the first time step + ENDIF + ! + DO jk = 1, jpkm1 !== Horizontal divergence ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + hdivn(ji,jj,jk) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * un(ji ,jj,jk) & + & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * un(ji-1,jj,jk) & + & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vn(ji,jj ,jk) & + & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vn(ji,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + IF( l_Westedge ) hdivn( 2 , : ,:) = 0._wp ! west + IF( l_Eastedge ) hdivn( nlci-1, : ,:) = 0._wp ! east + IF( l_Southedge ) hdivn( : , 2 ,:) = 0._wp ! south + IF( l_Northedge ) hdivn( : ,nlcj-1,:) = 0._wp ! north + ENDIF +#endif + ! + IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) !== runoffs ==! (update hdivn field) + ! +#if defined key_asminc + IF( ln_sshinc .AND. ln_asmiau ) CALL ssh_asm_div( kt, hdivn ) !== SSH assimilation ==! (update hdivn field) + ! +#endif + IF( ln_isf ) CALL sbc_isf_div( hdivn ) !== ice shelf ==! (update hdivn field) + ! + IF( ln_iscpl .AND. ln_hsb ) CALL iscpl_div( hdivn ) !== ice sheet ==! (update hdivn field) + ! + CALL lbc_lnk( 'divhor', hdivn, 'T', 1. ) ! (no sign change) + ! + IF( ln_timing ) CALL timing_stop('div_hor') + ! + END SUBROUTINE div_hor + + !!====================================================================== +END MODULE divhor diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynadv.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynadv.F90 new file mode 100644 index 0000000..e2d2179 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynadv.F90 @@ -0,0 +1,148 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_adv *** + !! + !! ** Purpose : compute the ocean momentum advection trend. + !! + !! ** Method : - Update (ua,va) 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 + !!---------------------------------------------------------------------- + ! + 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 ) ! vector form : horizontal gradient of kinetic energy + CALL dyn_zad ( kt ) ! vector form : vertical advection + CASE( np_FLX_c2 ) + CALL dyn_adv_cen2( kt ) ! 2nd order centered scheme + CASE( np_FLX_ubs ) + CALL dyn_adv_ubs ( kt ) ! 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 + ! + REWIND( numnam_ref ) ! Namelist namdyn_adv in reference namelist : Momentum advection scheme + READ ( numnam_ref, namdyn_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_adv in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namdyn_adv in configuration namelist : Momentum advection scheme + 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/NEMO_4.0.4_surge/src/OCE/DYN/dynadv_cen2.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynadv_cen2.F90 new file mode 100644 index 0000000..2776408 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynadv_cen2.F90 @@ -0,0 +1,147 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv_cen2( kt ) + !!---------------------------------------------------------------------- + !! *** 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 : (ua,va) updated with the now vorticity term trend + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_f, zfu_uw, zfu + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_adv_cen2 : 2nd order flux form momentum advection' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + IF( l_trddyn ) THEN ! trends: store the input trends + zfu_uw(:,:,:) = ua(:,:,:) + zfv_vw(:,:,:) = va(:,:,:) + ENDIF + ! + ! !== Horizontal advection ==! + ! + DO jk = 1, jpkm1 ! horizontal transport + zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) + zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) + DO jj = 1, jpjm1 ! horizontal momentum fluxes (at T- and F-point) + DO ji = 1, fs_jpim1 ! vector opt. + zfu_t(ji+1,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji+1,jj ,jk) ) + zfv_f(ji ,jj ,jk) = ( zfv(ji,jj,jk) + zfv(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji ,jj+1,jk) ) + zfu_f(ji ,jj ,jk) = ( zfu(ji,jj,jk) + zfu(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji+1,jj ,jk) ) + zfv_t(ji ,jj+1,jk) = ( zfv(ji,jj,jk) + zfv(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji ,jj+1,jk) ) + END DO + END DO + DO jj = 2, jpjm1 ! divergence of horizontal momentum fluxes + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) - ( 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_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ( 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_n(ji,jj,jk) + END DO + END DO + END DO + ! + IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic + zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) + zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) + CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt ) + zfu_t(:,:,:) = ua(:,:,:) + zfv_t(:,:,:) = va(:,:,:) + ENDIF + ! + ! !== Vertical advection ==! + ! + DO jj = 2, jpjm1 ! surface/bottom advective fluxes set to zero + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1) + zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1) + END DO + END DO + ENDIF + DO jk = 2, jpkm1 ! interior advective fluxes + DO jj = 2, jpj ! 1/4 * Vertical transport + DO ji = 2, jpi + zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) + END DO + END DO + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji+1,jj ,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) + zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk) + zfw(ji ,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) + END DO + END DO + END DO + DO jk = 1, jpkm1 ! divergence of vertical momentum flux divergence + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) + END DO + END DO + END DO + ! + IF( l_trddyn ) THEN ! trends: send trend to trddyn for diagnostic + zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) + zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) + CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) + ENDIF + ! ! Control print + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' cen2 adv - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE dyn_adv_cen2 + + !!============================================================================== +END MODULE dynadv_cen2 diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynadv_ubs.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynadv_ubs.F90 new file mode 100644 index 0000000..0506f3c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynadv_ubs.F90 @@ -0,0 +1,240 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_adv_ubs( kt ) + !!---------------------------------------------------------------------- + !! *** 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 : - (ua,va) updated with the 3D advective momentum trends + !! + !! Reference : Shchepetkin & McWilliams, 2005, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zui, zvj, zfuj, zfvi, zl_u, zl_v ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfu_t, zfu_f, zfu_uw, zfu + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zfv_t, zfv_f, zfv_vw, zfv, zfw + REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: zlu_uu, zlu_uv + REAL(wp), DIMENSION(jpi,jpj,jpk,2) :: zlv_vv, zlv_vu + !!---------------------------------------------------------------------- + ! + 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 + ! + 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(:,:,:) = ua(:,:,:) + zfv_vw(:,:,:) = va(:,:,:) + ENDIF + ! ! =========================== ! + DO jk = 1, jpkm1 ! Laplacian of the velocity ! + ! ! =========================== ! + ! ! horizontal volume fluxes + zfu(:,:,jk) = e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) + zfv(:,:,jk) = e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) + ! + DO jj = 2, jpjm1 ! laplacian + DO ji = fs_2, fs_jpim1 ! vector opt. + zlu_uu(ji,jj,jk,1) = ( ub (ji+1,jj ,jk) - 2.*ub (ji,jj,jk) + ub (ji-1,jj ,jk) ) * umask(ji,jj,jk) + zlv_vv(ji,jj,jk,1) = ( vb (ji ,jj+1,jk) - 2.*vb (ji,jj,jk) + vb (ji ,jj-1,jk) ) * vmask(ji,jj,jk) + zlu_uv(ji,jj,jk,1) = ( ub (ji ,jj+1,jk) - ub (ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & + & - ( ub (ji ,jj ,jk) - ub (ji ,jj-1,jk) ) * fmask(ji ,jj-1,jk) + zlv_vu(ji,jj,jk,1) = ( vb (ji+1,jj ,jk) - vb (ji ,jj ,jk) ) * fmask(ji ,jj ,jk) & + & - ( vb (ji ,jj ,jk) - vb (ji-1,jj ,jk) ) * fmask(ji-1,jj ,jk) + ! + zlu_uu(ji,jj,jk,2) = ( zfu(ji+1,jj ,jk) - 2.*zfu(ji,jj,jk) + zfu(ji-1,jj ,jk) ) * umask(ji,jj,jk) + zlv_vv(ji,jj,jk,2) = ( zfv(ji ,jj+1,jk) - 2.*zfv(ji,jj,jk) + zfv(ji ,jj-1,jk) ) * 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 + CALL lbc_lnk_multi( 'dynadv_ubs', zlu_uu(:,:,:,1), 'U', 1. , zlu_uv(:,:,:,1), 'U', 1., & + & zlu_uu(:,:,:,2), 'U', 1. , zlu_uv(:,:,:,2), 'U', 1., & + & zlv_vv(:,:,:,1), 'V', 1. , zlv_vu(:,:,:,1), 'V', 1., & + & zlv_vv(:,:,:,2), 'V', 1. , zlv_vu(:,:,:,2), 'V', 1. ) + ! + ! ! ====================== ! + ! ! Horizontal advection ! + DO jk = 1, jpkm1 ! ====================== ! + ! ! horizontal volume fluxes + zfu(:,:,jk) = 0.25_wp * e2u(:,:) * e3u_n(:,:,jk) * un(:,:,jk) + zfv(:,:,jk) = 0.25_wp * e1v(:,:) * e3v_n(:,:,jk) * vn(:,:,jk) + ! + DO jj = 1, jpjm1 ! horizontal momentum fluxes at T- and F-point + DO ji = 1, fs_jpim1 ! vector opt. + zui = ( un(ji,jj,jk) + un(ji+1,jj ,jk) ) + zvj = ( vn(ji,jj,jk) + vn(ji ,jj+1,jk) ) + ! + 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) ) ) & + & * ( un(ji,jj,jk) + un(ji ,jj+1,jk) - gamma1 * zl_u ) + zfu_f(ji ,jj ,jk) = ( zfuj - gamma2 * ( zlu_uv(ji,jj,jk,2) + zlu_uv(ji ,jj+1,jk,2) ) ) & + & * ( vn(ji,jj,jk) + vn(ji+1,jj ,jk) - gamma1 * zl_v ) + END DO + END DO + DO jj = 2, jpjm1 ! divergence of horizontal momentum fluxes + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) - ( 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_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ( 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_n(ji,jj,jk) + END DO + END DO + END DO + IF( l_trddyn ) THEN ! trends: send trends to trddyn for diagnostic + zfu_uw(:,:,:) = ua(:,:,:) - zfu_uw(:,:,:) + zfv_vw(:,:,:) = va(:,:,:) - zfv_vw(:,:,:) + CALL trd_dyn( zfu_uw, zfv_vw, jpdyn_keg, kt ) + zfu_t(:,:,:) = ua(:,:,:) + zfv_t(:,:,:) = va(:,:,:) + ENDIF + ! ! ==================== ! + ! ! Vertical advection ! + ! ! ==================== ! + DO jj = 2, jpjm1 ! surface/bottom advective fluxes set to zero + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zfu_uw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji+1,jj) * wn(ji+1,jj,1) ) * un(ji,jj,1) + zfv_vw(ji,jj,1) = 0.5_wp * ( e1e2t(ji,jj) * wn(ji,jj,1) + e1e2t(ji,jj+1) * wn(ji,jj+1,1) ) * vn(ji,jj,1) + END DO + END DO + ENDIF + DO jk = 2, jpkm1 ! interior fluxes + DO jj = 2, jpj + DO ji = 2, jpi + zfw(ji,jj,jk) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) + END DO + END DO + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zfu_uw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji+1,jj,jk) ) * ( un(ji,jj,jk) + un(ji,jj,jk-1) ) + zfv_vw(ji,jj,jk) = ( zfw(ji,jj,jk)+ zfw(ji,jj+1,jk) ) * ( vn(ji,jj,jk) + vn(ji,jj,jk-1) ) + END DO + END DO + END DO + DO jk = 1, jpkm1 ! divergence of vertical momentum flux divergence + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) - ( zfu_uw(ji,jj,jk) - zfu_uw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ( zfv_vw(ji,jj,jk) - zfv_vw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) + END DO + END DO + END DO + ! + IF( l_trddyn ) THEN ! save the vertical advection trend for diagnostic + zfu_t(:,:,:) = ua(:,:,:) - zfu_t(:,:,:) + zfv_t(:,:,:) = va(:,:,:) - zfv_t(:,:,:) + CALL trd_dyn( zfu_t, zfv_t, jpdyn_zad, kt ) + ENDIF + ! ! Control print + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' ubs2 adv - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + END SUBROUTINE dyn_adv_ubs + + !!============================================================================== +END MODULE dynadv_ubs diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynhpg.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynhpg.F90 new file mode 100644 index 0000000..5a3450e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynhpg.F90 @@ -0,0 +1,1535 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 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) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_hpg( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE dyn_hpg *** + !! + !! ** Method : Call the hydrostatic pressure gradient routine + !! using the scheme defined in the namelist + !! + !! ** Action : - Update (ua,va) 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 + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_hpg') + ! + IF( l_trddyn ) THEN ! Temporary saving of ua and va trends (l_trddyn) + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + ENDIF + ! + SELECT CASE ( nhpg ) ! Hydrostatic pressure gradient computation + CASE ( np_zco ) ; CALL hpg_zco ( kt ) ! z-coordinate + CASE ( np_zps ) ; CALL hpg_zps ( kt ) ! z-coordinate plus partial steps (interpolation) + CASE ( np_sco ) ; CALL hpg_sco ( kt ) ! s-coordinate (standard jacobian formulation) + CASE ( np_djc ) ; CALL hpg_djc ( kt ) ! s-coordinate (Density Jacobian with Cubic polynomial) + CASE ( np_prj ) ; CALL hpg_prj ( kt ) ! s-coordinate (Pressure Jacobian scheme) + CASE ( np_isf ) ; CALL hpg_isf ( kt ) ! 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(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_hpg, kt ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' hpg - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_hpg') + ! + END SUBROUTINE dyn_hpg + + + SUBROUTINE dyn_hpg_init + !!---------------------------------------------------------------------- + !! *** 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 :: ioptio = 0 ! temporary integer + INTEGER :: ios ! Local integer output status for namelist read + !! + INTEGER :: ji, jj, jk, ikt ! dummy loop indices ISF + REAL(wp) :: znad + 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namdyn_hpg in reference namelist : Hydrostatic pressure gradient + READ ( numnam_ref, namdyn_hpg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_hpg in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namdyn_hpg in configuration namelist : Hydrostatic pressure gradient + 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( ln_hpg_djc ) & + & CALL ctl_stop('dyn_hpg_init : Density Jacobian: Cubic polynominal method', & + & ' currently disabled (bugs under investigation).' , & + & ' Please select either ln_hpg_sco or ln_hpg_prj instead' ) + ! + IF( .NOT.ln_linssh .AND. .NOT.(ln_hpg_sco.OR.ln_hpg_prj.OR.ln_hpg_isf) ) & + & CALL ctl_stop('dyn_hpg_init : non-linear free surface requires either ', & + & ' the standard jacobian formulation hpg_sco or ' , & + & ' the pressure jacobian formulation hpg_prj' ) + ! + IF( ln_hpg_isf ) THEN + IF( .NOT. ln_isfcav ) CALL ctl_stop( ' hpg_isf not available if ln_isfcav = false ' ) + ELSE + IF( ln_isfcav ) CALL ctl_stop( 'Only hpg_isf has been corrected to work with ice shelf cavity.' ) + ENDIF + ! + ! ! 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 ( .NOT. ln_isfcav ) THEN !--- no ice shelf load + riceload(:,:) = 0._wp + ! + ELSE !--- set an ice shelf load + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ice shelf case: set the ice-shelf load' + ALLOCATE( zts_top(jpi,jpj,jpts) , zrhd(jpi,jpj,jpk) , zrhdtop_isf(jpi,jpj) , ziceload(jpi,jpj) ) + ! + znad = 1._wp !- To use density and not density anomaly + ! + ! !- assume water displaced by the ice shelf is at T=-1.9 and S=34.4 (rude) + zts_top(:,:,jp_tem) = -1.9_wp ; zts_top(:,:,jp_sal) = 34.4_wp + ! + DO jk = 1, jpk !- compute density of the water displaced by the ice shelf + CALL eos( zts_top(:,:,:), gdept_n(:,:,jk), 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 + ziceload = 0._wp ! compute pressure due to ice shelf load + DO jj = 1, jpj ! (used to compute hpgi/j for all the level from 1 to miku/v) + DO ji = 1, jpi ! divided by 2 later + ikt = mikt(ji,jj) + ziceload(ji,jj) = ziceload(ji,jj) + (znad + zrhd(ji,jj,1) ) * e3w_n(ji,jj,1) * (1._wp - tmask(ji,jj,1)) + DO jk = 2, ikt-1 + ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhd(ji,jj,jk-1) + zrhd(ji,jj,jk)) * e3w_n(ji,jj,jk) & + & * (1._wp - tmask(ji,jj,jk)) + END DO + IF (ikt >= 2) ziceload(ji,jj) = ziceload(ji,jj) + (2._wp * znad + zrhdtop_isf(ji,jj) + zrhd(ji,jj,ikt-1)) & + & * ( risfdep(ji,jj) - gdept_n(ji,jj,ikt-1) ) + END DO + END DO + riceload(:,:) = ziceload(:,:) ! need to be saved for diaar5 + ! + DEALLOCATE( zts_top , zrhd , zrhdtop_isf , ziceload ) + ENDIF + ! + END SUBROUTINE dyn_hpg_init + + + SUBROUTINE hpg_zco( kt ) + !!--------------------------------------------------------------------- + !! *** 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 (ua,va). + !! ua = ua - 1/e1u * zhpi + !! va = va - 1/e2v * zhpj + !! + !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef0, zcoef1 ! temporary scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj + !!---------------------------------------------------------------------- + ! + 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 + + zcoef0 = - grav * 0.5_wp ! Local constant initialization + + ! Surface value + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zcoef1 = zcoef0 * e3w_n(ji,jj,1) + ! hydrostatic pressure gradient + zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = zcoef1 * ( rhd(ji,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) + ! add to the general momentum trend + ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + END DO + END DO + + ! + ! interior value (2=<jk=<jpkm1) + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zcoef1 = zcoef0 * e3w_n(ji,jj,jk) + ! hydrostatic pressure gradient + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) & + & + zcoef1 * ( ( rhd(ji+1,jj,jk)+rhd(ji+1,jj,jk-1) ) & + & - ( rhd(ji ,jj,jk)+rhd(ji ,jj,jk-1) ) ) * r1_e1u(ji,jj) + + zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) & + & + zcoef1 * ( ( rhd(ji,jj+1,jk)+rhd(ji,jj+1,jk-1) ) & + & - ( rhd(ji,jj, jk)+rhd(ji,jj ,jk-1) ) ) * r1_e2v(ji,jj) + ! add to the general momentum trend + ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + END DO + END DO + END DO + ! + END SUBROUTINE hpg_zco + + + SUBROUTINE hpg_zps( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_zps *** + !! + !! ** Method : z-coordinate plus partial steps case. blahblah... + !! + !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iku, ikv ! temporary integers + REAL(wp) :: zcoef0, zcoef1, zcoef2, zcoef3 ! temporary scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj + REAL(wp), DIMENSION(jpi,jpj) :: zgtsu, zgtsv, zgru, zgrv + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_zps : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ z-coordinate with partial steps - vector optimization' + ENDIF + + ! Partial steps: Compute NOW horizontal gradient of t, s, rd at the last ocean level + CALL zps_hde( kt, jpts, tsn, zgtsu, zgtsv, rhd, zgru , zgrv ) + + ! Local constant initialization + zcoef0 = - grav * 0.5_wp + + ! Surface value (also valid in partial step case) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zcoef1 = zcoef0 * e3w_n(ji,jj,1) + ! hydrostatic pressure gradient + zhpi(ji,jj,1) = zcoef1 * ( rhd(ji+1,jj ,1) - rhd(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = zcoef1 * ( rhd(ji ,jj+1,1) - rhd(ji,jj,1) ) * r1_e2v(ji,jj) + ! add to the general momentum trend + ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + END DO + END DO + + ! interior value (2=<jk=<jpkm1) + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zcoef1 = zcoef0 * e3w_n(ji,jj,jk) + ! hydrostatic pressure gradient + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) & + & + zcoef1 * ( ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) ) & + & - ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) ) ) * r1_e1u(ji,jj) + + zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) & + & + zcoef1 * ( ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) ) & + & - ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) ) ) * r1_e2v(ji,jj) + ! add to the general momentum trend + ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + END DO + END DO + END DO + + ! partial steps correction at the last level (use zgru & zgrv computed in zpshde.F90) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + zcoef2 = zcoef0 * MIN( e3w_n(ji,jj,iku), e3w_n(ji+1,jj ,iku) ) + zcoef3 = zcoef0 * MIN( e3w_n(ji,jj,ikv), e3w_n(ji ,jj+1,ikv) ) + IF( iku > 1 ) THEN ! on i-direction (level 2 or more) + ua (ji,jj,iku) = ua(ji,jj,iku) - 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) + ua (ji,jj,iku) = ua(ji,jj,iku) + 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) + va (ji,jj,ikv) = va(ji,jj,ikv) - 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) + va (ji,jj,ikv) = va(ji,jj,ikv) + 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 ) + !!--------------------------------------------------------------------- + !! *** 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 (ua,va). + !! ua = ua - 1/e1u * zhpi + !! va = va - 1/e2v * zhpj + !! + !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jii, jjj ! dummy loop indices + REAL(wp) :: zcoef0, zuap, zvap, znad, ztmp ! temporary scalars + LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + !!---------------------------------------------------------------------- + ! + IF( ln_wd_il ) ALLOCATE(zcpx(jpi,jpj), zcpy(jpi,jpj)) + ! + 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, OPA original scheme used' + ENDIF + ! + zcoef0 = - grav * 0.5_wp + IF ( ln_linssh ) THEN ; znad = 0._wp ! Fixed volume: density anomaly + ELSE ; znad = 1._wp ! Variable volume: density + ENDIF + ! + IF( ln_wd_il ) THEN + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj), sshn(ji+1,jj) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & + & MAX( sshn(ji,jj) , sshn(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 + ELSE IF(ll_tmp2) THEN + ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj), sshn(ji,jj+1) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & + & MAX( sshn(ji,jj) , sshn(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 sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji,jj+1) - sshn(ji,jj )) ) + ELSE + zcpy(ji,jj) = 0._wp + END IF + END DO + END DO + CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) + END IF + + IF (ln_2d) THEN + ! Surface value + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,1) = zcoef0 * ( e3w_n(ji+1,jj ,1) * znad & + & - e3w_n(ji ,jj ,1) * znad ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = zcoef0 * ( e3w_n(ji ,jj+1,1) * znad & + & - e3w_n(ji ,jj ,1) * znad ) * r1_e2v(ji,jj) + ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( 2._wp * znad ) & + & * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( 2._wp * znad ) & + & * ( gde3w_n(ji,jj+1,1) - gde3w_n(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) + zuap = zuap * zcpx(ji,jj) + zvap = zvap * zcpy(ji,jj) + ENDIF + + ! add to the general momentum trend + ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap * umask(ji,jj,1) + va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap * vmask(ji,jj,1) + END DO + END DO + + ! interior value (2=<jk=<jpkm1) + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj) & + & * ( e3w_n(ji+1,jj,jk) * ( 2*znad ) & + & - e3w_n(ji ,jj,jk) * ( 2*znad ) ) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj) & + & * ( e3w_n(ji,jj+1,jk) * ( 2*znad ) & + & - e3w_n(ji,jj ,jk) * ( 2*znad ) ) + ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( 2._wp * znad ) & + & * ( gde3w_n(ji+1,jj ,jk) - gde3w_n(ji,jj,jk) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( 2._wp * znad ) & + & * ( gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) + + IF( ln_wd_il ) THEN + zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) + zuap = zuap * zcpx(ji,jj) + zvap = zvap * zcpy(ji,jj) + ENDIF + + ! add to the general momentum trend + ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap * umask(ji,jj,1) + va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap * vmask(ji,jj,1) + END DO + END DO + END DO + + ELSE + + ! Surface value + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,1) = zcoef0 * ( e3w_n(ji+1,jj ,1) * ( znad + rhd(ji+1,jj ,1) ) & + & - e3w_n(ji ,jj ,1) * ( znad + rhd(ji ,jj ,1) ) ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = zcoef0 * ( e3w_n(ji ,jj+1,1) * ( znad + rhd(ji ,jj+1,1) ) & + & - e3w_n(ji ,jj ,1) * ( znad + rhd(ji ,jj ,1) ) ) * r1_e2v(ji,jj) + ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) + 2._wp * znad ) & + & * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) + 2._wp * znad ) & + & * ( gde3w_n(ji,jj+1,1) - gde3w_n(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) + zuap = zuap * zcpx(ji,jj) + zvap = zvap * zcpy(ji,jj) + ENDIF + ! + ! add to the general momentum trend + ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + zuap + va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + zvap + END DO + END DO + + ! interior value (2=<jk=<jpkm1) + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 * r1_e1u(ji,jj) & + & * ( e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) & + & - e3w_n(ji ,jj,jk) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) + 2*znad ) ) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 * r1_e2v(ji,jj) & + & * ( e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) & + & - e3w_n(ji,jj ,jk) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) + 2*znad ) ) + ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & + & * ( gde3w_n(ji+1,jj ,jk) - gde3w_n(ji,jj,jk) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & + & * ( gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk) ) * r1_e2v(ji,jj) + ! + IF( ln_wd_il ) THEN + zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) + zuap = zuap * zcpx(ji,jj) + zvap = zvap * zcpy(ji,jj) + ENDIF + ! + ! add to the general momentum trend + ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + zuap + va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + zvap + END DO + END DO + END DO + + ENDIF !ln_2d + ! + IF( ln_wd_il ) DEALLOCATE( zcpx , zcpy ) + ! + END SUBROUTINE hpg_sco + + + SUBROUTINE hpg_isf( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_isf *** + !! + !! ** 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 (ua,va). + !! ua = ua - 1/e1u * zhpi + !! va = va - 1/e2v * zhpj + !! iceload is added and partial cell case are added to the top and bottom + !! + !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, ikt, iktp1i, iktp1j ! dummy loop indices + REAL(wp) :: zcoef0, zuap, zvap, znad ! temporary scalars + REAL(wp), DIMENSION(jpi,jpj,jpk ) :: zhpi, zhpj + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts_top + REAL(wp), DIMENSION(jpi,jpj) :: zrhdtop_oce + !!---------------------------------------------------------------------- + ! + zcoef0 = - grav * 0.5_wp ! Local constant initialization + ! + znad=1._wp ! To use density and not density anomaly + ! + ! ! iniitialised to 0. zhpi zhpi + zhpi(:,:,:) = 0._wp ; zhpj(:,:,:) = 0._wp + + ! compute rhd at the ice/oce interface (ocean side) + ! usefull to reduce residual current in the test case ISOMIP with no melting + DO ji = 1, jpi + DO jj = 1, jpj + ikt = mikt(ji,jj) + zts_top(ji,jj,1) = tsn(ji,jj,ikt,1) + zts_top(ji,jj,2) = tsn(ji,jj,ikt,2) + END DO + END DO + CALL eos( zts_top, risfdep, zrhdtop_oce ) + +!================================================================================== +!===== Compute surface value ===================================================== +!================================================================================== + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ikt = mikt(ji,jj) + iktp1i = mikt(ji+1,jj) + iktp1j = mikt(ji,jj+1) + ! hydrostatic pressure gradient along s-surfaces and ice shelf pressure + ! we assume ISF is in isostatic equilibrium + zhpi(ji,jj,1) = zcoef0 / e1u(ji,jj) * ( 0.5_wp * e3w_n(ji+1,jj,iktp1i) & + & * ( 2._wp * znad + rhd(ji+1,jj,iktp1i) + zrhdtop_oce(ji+1,jj) ) & + & - 0.5_wp * e3w_n(ji,jj,ikt) & + & * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) ) & + & + ( riceload(ji+1,jj) - riceload(ji,jj)) ) + zhpj(ji,jj,1) = zcoef0 / e2v(ji,jj) * ( 0.5_wp * e3w_n(ji,jj+1,iktp1j) & + & * ( 2._wp * znad + rhd(ji,jj+1,iktp1j) + zrhdtop_oce(ji,jj+1) ) & + & - 0.5_wp * e3w_n(ji,jj,ikt) & + & * ( 2._wp * znad + rhd(ji,jj,ikt) + zrhdtop_oce(ji,jj) ) & + & + ( riceload(ji,jj+1) - riceload(ji,jj)) ) + ! s-coordinate pressure gradient correction (=0 if z coordinate) + zuap = -zcoef0 * ( rhd (ji+1,jj,1) + rhd (ji,jj,1) + 2._wp * znad ) & + & * ( gde3w_n(ji+1,jj,1) - gde3w_n(ji,jj,1) ) * r1_e1u(ji,jj) + zvap = -zcoef0 * ( rhd (ji,jj+1,1) + rhd (ji,jj,1) + 2._wp * znad ) & + & * ( gde3w_n(ji,jj+1,1) - gde3w_n(ji,jj,1) ) * r1_e2v(ji,jj) + ! add to the general momentum trend + ua(ji,jj,1) = ua(ji,jj,1) + (zhpi(ji,jj,1) + zuap) * umask(ji,jj,1) + va(ji,jj,1) = va(ji,jj,1) + (zhpj(ji,jj,1) + zvap) * vmask(ji,jj,1) + END DO + END DO +!================================================================================== +!===== Compute interior value ===================================================== +!================================================================================== + ! interior value (2=<jk=<jpkm1) + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) + zcoef0 / e1u(ji,jj) & + & * ( e3w_n(ji+1,jj,jk) * ( rhd(ji+1,jj,jk) + rhd(ji+1,jj,jk-1) + 2*znad ) * wmask(ji+1,jj,jk) & + & - e3w_n(ji ,jj,jk) * ( rhd(ji ,jj,jk) + rhd(ji ,jj,jk-1) + 2*znad ) * wmask(ji ,jj,jk) ) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) + zcoef0 / e2v(ji,jj) & + & * ( e3w_n(ji,jj+1,jk) * ( rhd(ji,jj+1,jk) + rhd(ji,jj+1,jk-1) + 2*znad ) * wmask(ji,jj+1,jk) & + & - e3w_n(ji,jj ,jk) * ( rhd(ji,jj, jk) + rhd(ji,jj ,jk-1) + 2*znad ) * wmask(ji,jj ,jk) ) + ! s-coordinate pressure gradient correction + zuap = -zcoef0 * ( rhd (ji+1,jj ,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & + & * ( gde3w_n(ji+1,jj ,jk) - gde3w_n(ji,jj,jk) ) / e1u(ji,jj) + zvap = -zcoef0 * ( rhd (ji ,jj+1,jk) + rhd (ji,jj,jk) + 2._wp * znad ) & + & * ( gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk) ) / e2v(ji,jj) + ! add to the general momentum trend + ua(ji,jj,jk) = ua(ji,jj,jk) + (zhpi(ji,jj,jk) + zuap) * umask(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + (zhpj(ji,jj,jk) + zvap) * vmask(ji,jj,jk) + END DO + END DO + END DO + ! + END SUBROUTINE hpg_isf + + + SUBROUTINE hpg_djc( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_djc *** + !! + !! ** Method : Density Jacobian with Cubic polynomial scheme + !! + !! Reference: Shchepetkin and McWilliams, J. Geophys. Res., 108(C3), 3090, 2003 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zcoef0, zep, cffw ! temporary scalars + REAL(wp) :: z1_10, cffu, cffx ! " " + REAL(wp) :: z1_12, cffv, cffy ! " " + LOGICAL :: ll_tmp1, ll_tmp2 ! local logical variables + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zhpj + REAL(wp), DIMENSION(jpi,jpj,jpk) :: dzx, dzy, dzz, dzu, dzv, dzw + REAL(wp), DIMENSION(jpi,jpj,jpk) :: drhox, drhoy, drhoz, drhou, drhov, drhow + REAL(wp), DIMENSION(jpi,jpj,jpk) :: rho_i, rho_j, rho_k + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + !!---------------------------------------------------------------------- + ! + IF( ln_wd_il ) THEN + ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj), sshn(ji+1,jj) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & + & MAX( sshn(ji,jj) , sshn(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 + ELSE IF(ll_tmp2) THEN + ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) + ELSE + zcpx(ji,jj) = 0._wp + END IF + + ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj), sshn(ji,jj+1) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & + & MAX( sshn(ji,jj) , sshn(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 sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji,jj+1) - sshn(ji,jj )) ) + ELSE + zcpy(ji,jj) = 0._wp + END IF + END DO + END DO + CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) + END IF + + 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 + + ! Local constant initialization + zcoef0 = - grav * 0.5_wp + z1_10 = 1._wp / 10._wp + z1_12 = 1._wp / 12._wp + + !---------------------------------------------------------------------------------------- + ! compute and store in provisional arrays elementary vertical and horizontal differences + !---------------------------------------------------------------------------------------- + +!!bug gm Not a true bug, but... dzz=e3w for dzx, dzy verify what it is really + + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + drhoz(ji,jj,jk) = rhd (ji ,jj ,jk) - rhd (ji,jj,jk-1) + dzz (ji,jj,jk) = gde3w_n(ji ,jj ,jk) - gde3w_n(ji,jj,jk-1) + drhox(ji,jj,jk) = rhd (ji+1,jj ,jk) - rhd (ji,jj,jk ) + dzx (ji,jj,jk) = gde3w_n(ji+1,jj ,jk) - gde3w_n(ji,jj,jk ) + drhoy(ji,jj,jk) = rhd (ji ,jj+1,jk) - rhd (ji,jj,jk ) + dzy (ji,jj,jk) = gde3w_n(ji ,jj+1,jk) - gde3w_n(ji,jj,jk ) + END DO + END DO + END DO + + !------------------------------------------------------------------------- + ! compute harmonic averages using eq. 5.18 + !------------------------------------------------------------------------- + zep = 1.e-15 + +!!bug gm drhoz not defined at level 1 and used (jk-1 with jk=2) +!!bug gm idem for drhox, drhoy et ji=jpi and jj=jpj + + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + cffw = 2._wp * drhoz(ji ,jj ,jk) * drhoz(ji,jj,jk-1) + + cffu = 2._wp * drhox(ji+1,jj ,jk) * drhox(ji,jj,jk ) + cffx = 2._wp * dzx (ji+1,jj ,jk) * dzx (ji,jj,jk ) + + cffv = 2._wp * drhoy(ji ,jj+1,jk) * drhoy(ji,jj,jk ) + cffy = 2._wp * dzy (ji ,jj+1,jk) * dzy (ji,jj,jk ) + + IF( cffw > zep) THEN + drhow(ji,jj,jk) = 2._wp * drhoz(ji,jj,jk) * drhoz(ji,jj,jk-1) & + & / ( drhoz(ji,jj,jk) + drhoz(ji,jj,jk-1) ) + ELSE + drhow(ji,jj,jk) = 0._wp + ENDIF + + dzw(ji,jj,jk) = 2._wp * dzz(ji,jj,jk) * dzz(ji,jj,jk-1) & + & / ( dzz(ji,jj,jk) + dzz(ji,jj,jk-1) ) + + IF( cffu > zep ) THEN + drhou(ji,jj,jk) = 2._wp * drhox(ji+1,jj,jk) * drhox(ji,jj,jk) & + & / ( drhox(ji+1,jj,jk) + drhox(ji,jj,jk) ) + ELSE + drhou(ji,jj,jk ) = 0._wp + ENDIF + + IF( cffx > zep ) THEN + dzu(ji,jj,jk) = 2._wp * dzx(ji+1,jj,jk) * dzx(ji,jj,jk) & + & / ( dzx(ji+1,jj,jk) + dzx(ji,jj,jk) ) + ELSE + dzu(ji,jj,jk) = 0._wp + ENDIF + + IF( cffv > zep ) THEN + drhov(ji,jj,jk) = 2._wp * drhoy(ji,jj+1,jk) * drhoy(ji,jj,jk) & + & / ( drhoy(ji,jj+1,jk) + drhoy(ji,jj,jk) ) + ELSE + drhov(ji,jj,jk) = 0._wp + ENDIF + + IF( cffy > zep ) THEN + dzv(ji,jj,jk) = 2._wp * dzy(ji,jj+1,jk) * dzy(ji,jj,jk) & + & / ( dzy(ji,jj+1,jk) + dzy(ji,jj,jk) ) + ELSE + dzv(ji,jj,jk) = 0._wp + ENDIF + + END DO + END DO + END DO + + !---------------------------------------------------------------------------------- + ! apply boundary conditions at top and bottom using 5.36-5.37 + !---------------------------------------------------------------------------------- + drhow(:,:, 1 ) = 1.5_wp * ( drhoz(:,:, 2 ) - drhoz(:,:, 1 ) ) - 0.5_wp * drhow(:,:, 2 ) + drhou(:,:, 1 ) = 1.5_wp * ( drhox(:,:, 2 ) - drhox(:,:, 1 ) ) - 0.5_wp * drhou(:,:, 2 ) + drhov(:,:, 1 ) = 1.5_wp * ( drhoy(:,:, 2 ) - drhoy(:,:, 1 ) ) - 0.5_wp * drhov(:,:, 2 ) + + drhow(:,:,jpk) = 1.5_wp * ( drhoz(:,:,jpk) - drhoz(:,:,jpkm1) ) - 0.5_wp * drhow(:,:,jpkm1) + drhou(:,:,jpk) = 1.5_wp * ( drhox(:,:,jpk) - drhox(:,:,jpkm1) ) - 0.5_wp * drhou(:,:,jpkm1) + drhov(:,:,jpk) = 1.5_wp * ( drhoy(:,:,jpk) - drhoy(:,:,jpkm1) ) - 0.5_wp * drhov(:,:,jpkm1) + + + !-------------------------------------------------------------- + ! Upper half of top-most grid box, compute and store + !------------------------------------------------------------- + +!!bug gm : e3w-gde3w = 0.5*e3w .... and gde3w(2)-gde3w(1)=e3w(2) .... to be verified +! true if gde3w is really defined as the sum of the e3w scale factors as, it seems to me, it should be + + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + rho_k(ji,jj,1) = -grav * ( e3w_n(ji,jj,1) - gde3w_n(ji,jj,1) ) & + & * ( rhd(ji,jj,1) & + & + 0.5_wp * ( rhd (ji,jj,2) - rhd (ji,jj,1) ) & + & * ( e3w_n (ji,jj,1) - gde3w_n(ji,jj,1) ) & + & / ( gde3w_n(ji,jj,2) - gde3w_n(ji,jj,1) ) ) + END DO + END DO + +!!bug gm : here also, simplification is possible +!!bug gm : optimisation: 1/10 and 1/12 the division should be done before the loop + + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + + rho_k(ji,jj,jk) = zcoef0 * ( rhd (ji,jj,jk) + rhd (ji,jj,jk-1) ) & + & * ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) ) & + & - grav * z1_10 * ( & + & ( drhow (ji,jj,jk) - drhow (ji,jj,jk-1) ) & + & * ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) - z1_12 * ( dzw (ji,jj,jk) + dzw (ji,jj,jk-1) ) ) & + & - ( dzw (ji,jj,jk) - dzw (ji,jj,jk-1) ) & + & * ( rhd (ji,jj,jk) - rhd (ji,jj,jk-1) - z1_12 * ( drhow(ji,jj,jk) + drhow(ji,jj,jk-1) ) ) & + & ) + + rho_i(ji,jj,jk) = zcoef0 * ( rhd (ji+1,jj,jk) + rhd (ji,jj,jk) ) & + & * ( gde3w_n(ji+1,jj,jk) - gde3w_n(ji,jj,jk) ) & + & - grav* z1_10 * ( & + & ( drhou (ji+1,jj,jk) - drhou (ji,jj,jk) ) & + & * ( gde3w_n(ji+1,jj,jk) - gde3w_n(ji,jj,jk) - z1_12 * ( dzu (ji+1,jj,jk) + dzu (ji,jj,jk) ) ) & + & - ( dzu (ji+1,jj,jk) - dzu (ji,jj,jk) ) & + & * ( rhd (ji+1,jj,jk) - rhd (ji,jj,jk) - z1_12 * ( drhou(ji+1,jj,jk) + drhou(ji,jj,jk) ) ) & + & ) + + rho_j(ji,jj,jk) = zcoef0 * ( rhd (ji,jj+1,jk) + rhd (ji,jj,jk) ) & + & * ( gde3w_n(ji,jj+1,jk) - gde3w_n(ji,jj,jk) ) & + & - grav* z1_10 * ( & + & ( drhov (ji,jj+1,jk) - drhov (ji,jj,jk) ) & + & * ( gde3w_n(ji,jj+1,jk) - gde3w_n(ji,jj,jk) - z1_12 * ( dzv (ji,jj+1,jk) + dzv (ji,jj,jk) ) ) & + & - ( dzv (ji,jj+1,jk) - dzv (ji,jj,jk) ) & + & * ( rhd (ji,jj+1,jk) - rhd (ji,jj,jk) - z1_12 * ( drhov(ji,jj+1,jk) + drhov(ji,jj,jk) ) ) & + & ) + + END DO + END DO + END DO + CALL lbc_lnk_multi( 'dynhpg', rho_k, 'W', 1., rho_i, 'U', 1., rho_j, 'V', 1. ) + + ! --------------- + ! Surface value + ! --------------- + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zhpi(ji,jj,1) = ( rho_k(ji+1,jj ,1) - rho_k(ji,jj,1) - rho_i(ji,jj,1) ) * r1_e1u(ji,jj) + zhpj(ji,jj,1) = ( rho_k(ji ,jj+1,1) - rho_k(ji,jj,1) - 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 + ua(ji,jj,1) = ua(ji,jj,1) + zhpi(ji,jj,1) + va(ji,jj,1) = va(ji,jj,1) + zhpj(ji,jj,1) + END DO + END DO + + ! ---------------- + ! interior value (2=<jk=<jpkm1) + ! ---------------- + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! hydrostatic pressure gradient along s-surfaces + zhpi(ji,jj,jk) = zhpi(ji,jj,jk-1) & + & + ( ( rho_k(ji+1,jj,jk) - rho_k(ji,jj,jk ) ) & + & - ( rho_i(ji ,jj,jk) - rho_i(ji,jj,jk-1) ) ) * r1_e1u(ji,jj) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk-1) & + & + ( ( rho_k(ji,jj+1,jk) - rho_k(ji,jj,jk ) ) & + & -( rho_j(ji,jj ,jk) - rho_j(ji,jj,jk-1) ) ) * r1_e2v(ji,jj) + IF( ln_wd_il ) THEN + zhpi(ji,jj,jk) = zhpi(ji,jj,jk) * zcpx(ji,jj) + zhpj(ji,jj,jk) = zhpj(ji,jj,jk) * zcpy(ji,jj) + ENDIF + ! add to the general momentum trend + ua(ji,jj,jk) = ua(ji,jj,jk) + zhpi(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + zhpj(ji,jj,jk) + END DO + END DO + END DO + ! + IF( ln_wd_il ) DEALLOCATE( zcpx, zcpy ) + ! + END SUBROUTINE hpg_djc + + + SUBROUTINE hpg_prj( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE hpg_prj *** + !! + !! ** Method : s-coordinate case. + !! A Pressure-Jacobian horizontal pressure gradient method + !! based on the constrained cubic-spline interpolation for + !! all vertical coordinate systems + !! + !! ** Action : - Update (ua,va) with the now hydrastatic pressure trend + !!---------------------------------------------------------------------- + INTEGER, PARAMETER :: polynomial_type = 1 ! 1: cubic spline, 2: linear + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk, jkk ! dummy loop indices + 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(wp) :: zuijk, zvijk, zpwes, zpwed, zpnss, zpnsd, zdeps + REAL(wp) :: zrhdt1 + REAL(wp) :: zdpdx1, zdpdx2, zdpdy1, zdpdy2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdept, zrhh + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhpi, zu, zv, fsp, xsp, asp, bsp, csp, dsp + REAL(wp), DIMENSION(jpi,jpj) :: zsshu_n, zsshv_n + REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zcpx, zcpy !W/D pressure filter + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn:hpg_prj : hydrostatic pressure gradient trend' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ s-coordinate case, cubic spline pressure Jacobian' + ENDIF + + ! Local constant initialization + zcoef0 = - grav + znad = 1._wp + IF( ln_linssh ) znad = 0._wp + + IF( ln_wd_il ) THEN + ALLOCATE( zcpx(jpi,jpj) , zcpy(jpi,jpj) ) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj), sshn(ji+1,jj) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji+1,jj) ) > 1.E-12 ) .AND. ( & + & MAX( sshn(ji,jj) , sshn(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 + ELSE IF(ll_tmp2) THEN + ! no worries about sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji+1,jj) - sshn(ji ,jj)) ) + + 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( sshn(ji,jj) , sshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj), sshn(ji,jj+1) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1) ) > 1.E-12 ) .AND. ( & + & MAX( sshn(ji,jj) , sshn(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 sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji,jj+1) - sshn(ji,jj )) ) + 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 + CALL lbc_lnk_multi( 'dynhpg', zcpx, 'U', 1., zcpy, 'V', 1. ) + ENDIF + + ! Clean 3-D work arrays + zhpi(:,:,:) = 0._wp + zrhh(:,:,:) = rhd(:,:,:) + + ! Preparing vertical density profile "zrhh(:,:,:)" for hybrid-sco coordinate + DO jj = 1, jpj + DO ji = 1, jpi + 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(gde3w_n(ji,jj,jkk ), gde3w_n(ji,jj,jkk-1), & + & gde3w_n(ji,jj,jkk-2), 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 = 1, jpj + DO ji = 1, jpi + zdept(ji,jj,1) = 0.5_wp * e3w_n(ji,jj,1) - sshn(ji,jj) * znad + END DO + END DO + + DO jk = 2, jpk + DO jj = 1, jpj + DO ji = 1, jpi + zdept(ji,jj,jk) = zdept(ji,jj,jk-1) + e3w_n(ji,jj,jk) + 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 = 2, jpj + DO ji = 2, jpi + 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_n(ji,jj,1) + + ! assuming linear profile across the top half surface layer + zhpi(ji,jj,1) = 0.5_wp * e3w_n(ji,jj,1) * zrhdt1 + END DO + END DO + + ! Calculate the pressure "zhpi(:,:,:)" at "T(ji,jj,2:jpkm1)" + DO jk = 2, jpkm1 + DO jj = 2, jpj + DO ji = 2, jpi + 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 = 2, jpjm1 + DO ji = 2, jpim1 +!!gm BUG ? if it is ssh at u- & v-point then it should be: +! zsshu_n(ji,jj) = (e1e2t(ji,jj) * sshn(ji,jj) + e1e2t(ji+1,jj) * sshn(ji+1,jj)) * & +! & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp +! zsshv_n(ji,jj) = (e1e2t(ji,jj) * sshn(ji,jj) + e1e2t(ji,jj+1) * sshn(ji,jj+1)) * & +! & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp +!!gm not this: + zsshu_n(ji,jj) = (e1e2u(ji,jj) * sshn(ji,jj) + e1e2u(ji+1, jj) * sshn(ji+1,jj)) * & + & r1_e1e2u(ji,jj) * umask(ji,jj,1) * 0.5_wp + zsshv_n(ji,jj) = (e1e2v(ji,jj) * sshn(ji,jj) + e1e2v(ji+1, jj) * sshn(ji,jj+1)) * & + & r1_e1e2v(ji,jj) * vmask(ji,jj,1) * 0.5_wp + END DO + END DO + + CALL lbc_lnk_multi ('dynhpg', zsshu_n, 'U', 1., zsshv_n, 'V', 1. ) + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zu(ji,jj,1) = - ( e3u_n(ji,jj,1) - zsshu_n(ji,jj) * znad) + zv(ji,jj,1) = - ( e3v_n(ji,jj,1) - zsshv_n(ji,jj) * znad) + END DO + END DO + + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zu(ji,jj,jk) = zu(ji,jj,jk-1) - e3u_n(ji,jj,jk) + zv(ji,jj,jk) = zv(ji,jj,jk-1) - e3v_n(ji,jj,jk) + END DO + END DO + END DO + + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zu(ji,jj,jk) = zu(ji,jj,jk) + 0.5_wp * e3u_n(ji,jj,jk) + zv(ji,jj,jk) = zv(ji,jj,jk) + 0.5_wp * e3v_n(ji,jj,jk) + END DO + END DO + END DO + + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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, sshn(jid,jj)*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) + (sshn(ji+1,jj)-sshn(ji,jj)) ) + 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 + ua(ji,jj,jk) = ua(ji,jj,jk) + (zdpdx1 + zdpdx2) * 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, sshn(ji,jjd)*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) + (sshn(ji,jj+1)-sshn(ji,jj)) ) + 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 + + va(ji,jj,jk) = va(ji,jj,jk) + (zdpdy1 + zdpdy2) * 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(:,:,:), INTENT(in ) :: fsp, xsp ! value and coordinate + REAL(wp), DIMENSION(:,:,:), 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 + INTEGER :: jpi, jpj, jpkm1 + REAL(wp) :: zdf1, zdf2, zddf1, zddf2, ztmp1, ztmp2, zdxtmp + REAL(wp) :: zdxtmp1, zdxtmp2, zalpha + REAL(wp) :: zdf(size(fsp,3)) + !!---------------------------------------------------------------------- + ! +!!gm WHAT !!!!! THIS IS VERY DANGEROUS !!!!! + jpi = size(fsp,1) + jpj = size(fsp,2) + jpkm1 = MAX( 1, size(fsp,3) - 1 ) + ! + IF (polynomial_type == 1) THEN ! Constrained Cubic Spline + DO ji = 1, jpi + DO jj = 1, jpj + !!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, jpkm1-1 + 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(jpkm1 - 1) + + DO jk = 1, jpkm1 - 1 + 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 ji = 1, jpi + DO jj = 1, jpj + DO jk = 1, jpkm1-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) :: x, xl, xr, fl, fr + 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/NEMO_4.0.4_surge/src/OCE/DYN/dynkeg.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynkeg.F90 new file mode 100644 index 0000000..35ad4e4 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynkeg.F90 @@ -0,0 +1,157 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_keg( kt, kscheme ) + !!---------------------------------------------------------------------- + !! *** 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 + ((un(j+1)+un(j-1))/2)^2 ) + !! + mj-1( 2 * vn^2 + ((vn(i+1)+vn(i-1))/2)^2 ) ] + !! + !! Take its horizontal gradient and add it to the general momentum + !! trend (ua,va). + !! ua = ua - 1/e1u di[ zhke ] + !! va = va - 1/e2v dj[ zhke ] + !! + !! ** Action : - Update the (ua, va) 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 :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zu, zv ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zhke + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_keg') + ! + 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 + + IF( l_trddyn ) THEN ! Save the input trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + 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 = 2, jpj + DO ji = fs_2, jpi ! vector opt. + zu = un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & + & + un(ji ,jj ,jk) * un(ji ,jj ,jk) + zv = vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & + & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) + 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 = 2, jpjm1 + DO ji = fs_2, jpim1 ! vector opt. + zu = 8._wp * ( un(ji-1,jj ,jk) * un(ji-1,jj ,jk) & + & + un(ji ,jj ,jk) * un(ji ,jj ,jk) ) & + & + ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) * ( un(ji-1,jj-1,jk) + un(ji-1,jj+1,jk) ) & + & + ( un(ji ,jj-1,jk) + un(ji ,jj+1,jk) ) * ( un(ji ,jj-1,jk) + un(ji ,jj+1,jk) ) + ! + zv = 8._wp * ( vn(ji ,jj-1,jk) * vn(ji ,jj-1,jk) & + & + vn(ji ,jj ,jk) * vn(ji ,jj ,jk) ) & + & + ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) * ( vn(ji-1,jj-1,jk) + vn(ji+1,jj-1,jk) ) & + & + ( vn(ji-1,jj ,jk) + vn(ji+1,jj ,jk) ) * ( vn(ji-1,jj ,jk) + vn(ji+1,jj ,jk) ) + zhke(ji,jj,jk) = r1_48 * ( zv + zu ) + END DO + END DO + END DO + CALL lbc_lnk( 'dynkeg', zhke, 'T', 1. ) + ! + END SELECT + ! + DO jk = 1, jpkm1 !== grad( KE ) added to the general momentum trends ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) - ( zhke(ji+1,jj ,jk) - zhke(ji,jj,jk) ) / e1u(ji,jj)* umask(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ( zhke(ji ,jj+1,jk) - zhke(ji,jj,jk) ) / e2v(ji,jj)* vmask(ji,jj,jk) + END DO + END DO + END DO + ! + IF( l_trddyn ) THEN ! save the Kinetic Energy trends for diagnostic + ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_keg, kt ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' keg - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_keg') + ! + END SUBROUTINE dyn_keg + + !!====================================================================== +END MODULE dynkeg diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynldf.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynldf.F90 new file mode 100644 index 0000000..1fe8715 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynldf.F90 @@ -0,0 +1,113 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_ldf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf *** + !! + !! ** Purpose : compute the lateral ocean dynamics physics. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + REAL(wp), 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(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + ENDIF + + SELECT CASE ( nldf_dyn ) ! compute lateral mixing trend and add it to the general trend + ! + CASE ( np_lap ) ; CALL dyn_ldf_lap( kt, ub, vb, ua, va, 1 ) ! iso-level laplacian + CASE ( np_lap_i ) ; CALL dyn_ldf_iso( kt ) ! rotated laplacian + CASE ( np_blp ) ; CALL dyn_ldf_blp( kt, ub, vb, ua, va ) ! iso-level bi-laplacian + ! + END SELECT + + IF( l_trddyn ) THEN ! save the horizontal diffusive trends for further diagnostics + ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_ldf, kt ) + DEALLOCATE ( ztrdu , ztrdv ) + ENDIF + ! ! print sum trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' ldf - Ua: ', mask1=umask, & + & tab3d_2=va, 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/NEMO_4.0.4_surge/src/OCE/DYN/dynldf_iso.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynldf_iso.F90 new file mode 100644 index 0000000..11ce7ae --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynldf_iso.F90 @@ -0,0 +1,403 @@ +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 + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfuw, zdiu, zdju, zdj1u ! 2D workspace (dyn_ldf_iso) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: zfvw, zdiv, zdjv, zdj1v ! - - + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION dyn_ldf_iso_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_ldf_iso_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( akzu(jpi,jpj,jpk) , zfuw(jpi,jpk) , zdiu(jpi,jpk) , zdju(jpi,jpk) , zdj1u(jpi,jpk) , & + & akzv(jpi,jpj,jpk) , zfvw(jpi,jpk) , zdiv(jpi,jpk) , zdjv(jpi,jpk) , zdj1v(jpi,jpk) , STAT=dyn_ldf_iso_alloc ) + ! + IF( dyn_ldf_iso_alloc /= 0 ) CALL ctl_warn('dyn_ldf_iso_alloc: array allocate failed.') + END FUNCTION dyn_ldf_iso_alloc + + + SUBROUTINE dyn_ldf_iso( kt ) + !!---------------------------------------------------------------------- + !! *** 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[ ub ] + !! - ahmt e2t * mi-1(uslp) dk[ mi(mk(ub)) ] + !! zjuf = ( ahmf + rn_ahm_b ) e1f * e3f / e2f dj[ ub ] + !! - ahmf e1f * mi(vslp) dk[ mj(mk(ub)) ] + !! v-component: + !! zivf = ( ahmf + rn_ahm_b ) e2t * e3t / e1t di[ vb ] + !! - ahmf e2t * mj(uslp) dk[ mi(mk(vb)) ] + !! zjvt = ( ahmt + rn_ahm_b ) e1f * e3f / e2f dj[ ub ] + !! - ahmt e1f * mj-1(vslp) dk[ mj(mk(vb)) ] + !! 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 (ua,va): + !! ua = ua + diffu + !! CAUTION: here the isopycnal part is with a coeff. of aht. This + !! should be modified for applications others than orca_r2 (!!bug) + !! + !! ** Action : + !! -(ua,va) 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 :: 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(jpi,jpj) :: ziut, zivf, zdku, zdk1u ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zjuf, zjvt, zdkv, zdk1v ! - - + !!---------------------------------------------------------------------- + ! + 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_bilap arrays + IF( dyn_ldf_iso_alloc() /= 0 ) CALL ctl_stop('STOP', 'dyn_ldf_iso: failed to allocate arrays') + 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 ! set the slopes of iso-level + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + uslp (ji,jj,jk) = - ( gdept_b(ji+1,jj,jk) - gdept_b(ji ,jj ,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) + vslp (ji,jj,jk) = - ( gdept_b(ji,jj+1,jk) - gdept_b(ji ,jj ,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) + wslpi(ji,jj,jk) = - ( gdepw_b(ji+1,jj,jk) - gdepw_b(ji-1,jj,jk) ) * r1_e1t(ji,jj) * tmask(ji,jj,jk) * 0.5 + wslpj(ji,jj,jk) = - ( gdepw_b(ji,jj+1,jk) - gdepw_b(ji,jj-1,jk) ) * r1_e2t(ji,jj) * tmask(ji,jj,jk) * 0.5 + END DO + END DO + END DO + ! Lateral boundary conditions on the slopes + CALL lbc_lnk_multi( 'dynldf_iso', uslp , 'U', -1., vslp , 'V', -1., wslpi, 'W', -1., wslpj, 'W', -1. ) + ! + 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) + + zdk1u(:,:) = ( ub(:,:,jk) -ub(:,:,jk+1) ) * umask(:,:,jk+1) + zdk1v(:,:) = ( vb(:,:,jk) -vb(:,:,jk+1) ) * vmask(:,:,jk+1) + + IF( jk == 1 ) THEN + zdku(:,:) = zdk1u(:,:) + zdkv(:,:) = zdk1v(:,:) + ELSE + zdku(:,:) = ( ub(:,:,jk-1) - ub(:,:,jk) ) * umask(:,:,jk) + zdkv(:,:) = ( vb(:,:,jk-1) - vb(:,:,jk) ) * vmask(:,:,jk) + 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 = 2, jpjm1 + DO ji = fs_2, jpi ! vector opt. + zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * MIN( e3u_n(ji,jj,jk), e3u_n(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 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) ) & + & + 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 = 2, jpjm1 + DO ji = fs_2, jpi ! vector opt. + zabe1 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e2t(ji,jj) * e3t_n(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 * ( ub(ji,jj,jk) - ub(ji-1,jj,jk) ) & + & + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zabe2 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e1f(ji,jj) * e3f_n(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 * ( ub(ji,jj+1,jk) - ub(ji,jj,jk) ) & + & + 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 = 2, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zabe1 = ( ahmf(ji,jj,jk) + rn_ahm_b ) * e2f(ji,jj) * e3f_n(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 * ( vb(ji+1,jj,jk) - vb(ji,jj,jk) ) & + & + 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 = 2, jpj + DO ji = 1, fs_jpim1 ! vector opt. + zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * MIN( e3v_n(ji,jj,jk), e3v_n(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 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) ) & + & + 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 = 2, jpj + DO ji = 1, fs_jpim1 ! vector opt. + zabe2 = ( ahmt(ji,jj,jk)+rn_ahm_b ) * e1t(ji,jj) * e3t_n(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 * ( vb(ji,jj,jk) - vb(ji,jj-1,jk) ) & + & + 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 = 2, jpjm1 + DO ji = 2, jpim1 !!gm Question vectop possible??? !!bug + ua(ji,jj,jk) = ua(ji,jj,jk) + ( ziut(ji+1,jj) - ziut(ji,jj ) & + & + zjuf(ji ,jj) - zjuf(ji,jj-1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + ( zivf(ji,jj ) - zivf(ji-1,jj) & + & + zjvt(ji,jj+1) - zjvt(ji,jj ) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) + END DO + END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + + ! print sum trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' ldfh - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + + + ! ! =============== + DO jj = 2, jpjm1 ! 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 = 2, jpi + ! i-gradient of u at jj + zdiu (ji,jk) = tmask(ji,jj ,jk) * ( ub(ji,jj ,jk) - ub(ji-1,jj ,jk) ) + ! j-gradient of u and v at jj + zdju (ji,jk) = fmask(ji,jj ,jk) * ( ub(ji,jj+1,jk) - ub(ji ,jj ,jk) ) + zdjv (ji,jk) = tmask(ji,jj ,jk) * ( vb(ji,jj ,jk) - vb(ji ,jj-1,jk) ) + ! j-gradient of u and v at jj+1 + zdj1u(ji,jk) = fmask(ji,jj-1,jk) * ( ub(ji,jj ,jk) - ub(ji ,jj-1,jk) ) + zdj1v(ji,jk) = tmask(ji,jj+1,jk) * ( vb(ji,jj+1,jk) - vb(ji ,jj ,jk) ) + END DO + END DO + DO jk = 1, jpk + DO ji = 1, jpim1 + ! i-gradient of v at jj + zdiv (ji,jk) = fmask(ji,jj ,jk) * ( vb(ji+1,jj,jk) - vb(ji ,jj ,jk) ) + END DO + END DO + + + ! I.2 Vertical fluxes + ! ------------------- + + ! Surface and bottom vertical fluxes set to zero + DO ji = 1, jpi + zfuw(ji, 1 ) = 0.e0 + zfvw(ji, 1 ) = 0.e0 + zfuw(ji,jpk) = 0.e0 + zfvw(ji,jpk) = 0.e0 + END DO + + ! interior (2=<jk=<jpk-1) on U field + DO jk = 2, jpkm1 + DO ji = 2, jpim1 + zcof0 = 0.5_wp * zaht_0 * umask(ji,jj,jk) + ! + zuwslpi = zcof0 * ( wslpi(ji+1,jj,jk) + wslpi(ji,jj,jk) ) + zuwslpj = zcof0 * ( wslpj(ji+1,jj,jk) + wslpj(ji,jj,jk) ) + ! + zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji+1,jj,jk-1) & + + tmask(ji,jj,jk )+tmask(ji+1,jj,jk ) , 1. ) + zmkf = 1./MAX( fmask(ji,jj-1,jk-1) + fmask(ji,jj,jk-1) & + + fmask(ji,jj-1,jk ) + fmask(ji,jj,jk ) , 1. ) + + zcof3 = - e2u(ji,jj) * zmkt * zuwslpi + zcof4 = - e1u(ji,jj) * zmkf * zuwslpj + ! vertical flux on u field + zfuw(ji,jk) = zcof3 * ( zdiu (ji,jk-1) + zdiu (ji+1,jk-1) & + & + zdiu (ji,jk ) + zdiu (ji+1,jk ) ) & + & + zcof4 * ( zdj1u(ji,jk-1) + zdju (ji ,jk-1) & + & + zdj1u(ji,jk ) + zdju (ji ,jk ) ) + ! vertical mixing coefficient (akzu) + ! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0 + akzu(ji,jj,jk) = ( zuwslpi * zuwslpi + zuwslpj * zuwslpj ) / zaht_0 + END DO + END DO + + ! interior (2=<jk=<jpk-1) on V field + DO jk = 2, jpkm1 + DO ji = 2, jpim1 + zcof0 = 0.5_wp * zaht_0 * vmask(ji,jj,jk) + ! + zvwslpi = zcof0 * ( wslpi(ji,jj+1,jk) + wslpi(ji,jj,jk) ) + zvwslpj = zcof0 * ( wslpj(ji,jj+1,jk) + wslpj(ji,jj,jk) ) + ! + zmkf = 1./MAX( fmask(ji-1,jj,jk-1)+fmask(ji,jj,jk-1) & + & + fmask(ji-1,jj,jk )+fmask(ji,jj,jk ) , 1. ) + zmkt = 1./MAX( tmask(ji,jj,jk-1)+tmask(ji,jj+1,jk-1) & + & + tmask(ji,jj,jk )+tmask(ji,jj+1,jk ) , 1. ) + + zcof3 = - e2v(ji,jj) * zmkf * zvwslpi + zcof4 = - e1v(ji,jj) * zmkt * zvwslpj + ! vertical flux on v field + zfvw(ji,jk) = zcof3 * ( zdiv (ji,jk-1) + zdiv (ji-1,jk-1) & + & + zdiv (ji,jk ) + zdiv (ji-1,jk ) ) & + & + zcof4 * ( zdjv (ji,jk-1) + zdj1v(ji ,jk-1) & + & + zdjv (ji,jk ) + zdj1v(ji ,jk ) ) + ! vertical mixing coefficient (akzv) + ! Note: zcof0 include zaht_0, so divided by zaht_0 to obtain slp^2 * zaht_0 + akzv(ji,jj,jk) = ( zvwslpi * zvwslpi + zvwslpj * zvwslpj ) / zaht_0 + END DO + END DO + + + ! I.3 Divergence of vertical fluxes added to the general tracer trend + ! ------------------------------------------------------------------- + DO jk = 1, jpkm1 + DO ji = 2, jpim1 + ua(ji,jj,jk) = ua(ji,jj,jk) + ( zfuw(ji,jk) - zfuw(ji,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + ( zfvw(ji,jk) - zfvw(ji,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) + END DO + END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE dyn_ldf_iso + + !!====================================================================== +END MODULE dynldf_iso diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynldf_lap_blp.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynldf_lap_blp.F90 new file mode 100644 index 0000000..6686e7c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynldf_lap_blp.F90 @@ -0,0 +1,142 @@ +MODULE dynldf_lap_blp + !!====================================================================== + !! *** 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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 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 lbclnk ! ocean lateral boundary conditions (or mpp link) + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_ldf_lap ! called by dynldf.F90 + PUBLIC dyn_ldf_blp ! called by dynldf.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_ldf_lap( kt, pub, pvb, pua, pva, 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 : - pua, pva increased by the harmonic operator applied on pub, pvb. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kpass ! =1/2 first or second passage + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pub, pvb ! before velocity [m/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! velocity trend [m/s2] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zsign ! local scalars + REAL(wp) :: zua, zva ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zcur, zdiv + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'dyn_ldf : iso-level harmonic (laplacian) operator, pass=', kpass + WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign + ELSE ; zsign = -1._wp ! (eddy viscosity coef. >0) + ENDIF + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + DO jj = 2, jpj + DO ji = fs_2, jpi ! vector opt. + ! ! ahm * e3 * curl (computed from 1 to jpim1/jpjm1) + zcur(ji-1,jj-1) = ahmf(ji-1,jj-1,jk) * e3f_n(ji-1,jj-1,jk) * r1_e1e2f(ji-1,jj-1) & ! ahmf already * by fmask + & * ( e2v(ji ,jj-1) * pvb(ji ,jj-1,jk) - e2v(ji-1,jj-1) * pvb(ji-1,jj-1,jk) & + & - e1u(ji-1,jj ) * pub(ji-1,jj ,jk) + e1u(ji-1,jj-1) * pub(ji-1,jj-1,jk) ) + ! ! ahm * div (computed from 2 to jpi/jpj) + zdiv(ji,jj) = ahmt(ji,jj,jk) * r1_e1e2t(ji,jj) / e3t_b(ji,jj,jk) & ! ahmt already * by tmask + & * ( e2u(ji,jj)*e3u_b(ji,jj,jk) * pub(ji,jj,jk) - e2u(ji-1,jj)*e3u_b(ji-1,jj,jk) * pub(ji-1,jj,jk) & + & + e1v(ji,jj)*e3v_b(ji,jj,jk) * pvb(ji,jj,jk) - e1v(ji,jj-1)*e3v_b(ji,jj-1,jk) * pvb(ji,jj-1,jk) ) + END DO + END DO + ! + DO jj = 2, jpjm1 ! - curl( curl) + grad( div ) + DO ji = fs_2, fs_jpim1 ! vector opt. + pua(ji,jj,jk) = pua(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_n(ji,jj,jk) & + & + ( zdiv(ji+1,jj) - zdiv(ji,jj ) ) * r1_e1u(ji,jj) ) + ! + pva(ji,jj,jk) = pva(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_n(ji,jj,jk) & + & + ( zdiv(ji,jj+1) - zdiv(ji ,jj) ) * r1_e2v(ji,jj) ) + END DO + END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + ! + END SUBROUTINE dyn_ldf_lap + + + SUBROUTINE dyn_ldf_blp( kt, pub, pvb, pua, pva ) + !!---------------------------------------------------------------------- + !! *** 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 : pta updated with the before rotated bilaplacian diffusion + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pub, pvb ! before velocity fields + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! momentum trend + ! + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zulap, zvlap ! laplacian at u- and v-point + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_ldf_blp : bilaplacian operator momentum ' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + zulap(:,:,:) = 0._wp + zvlap(:,:,:) = 0._wp + ! + CALL dyn_ldf_lap( kt, pub, pvb, zulap, zvlap, 1 ) ! rotated laplacian applied to ptb (output in zlap) + ! + CALL lbc_lnk_multi( 'dynldf_lap_blp', zulap, 'U', -1., zvlap, 'V', -1. ) ! Lateral boundary conditions + ! + CALL dyn_ldf_lap( kt, zulap, zvlap, pua, pva, 2 ) ! rotated laplacian applied to zlap (output in pta) + ! + END SUBROUTINE dyn_ldf_blp + + !!====================================================================== +END MODULE dynldf_lap_blp diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynnxt.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynnxt.F90 new file mode 100644 index 0000000..79a833f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynnxt.F90 @@ -0,0 +1,404 @@ +MODULE dynnxt + !!========================================================================= + !! *** MODULE dynnxt *** + !! Ocean dynamics: time stepping + !!========================================================================= + !! 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 + !!------------------------------------------------------------------------- + + !!------------------------------------------------------------------------- + !! dyn_nxt : obtain the next (after) horizontal velocity + !!------------------------------------------------------------------------- + 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 sbcisf ! ice shelf + 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 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 +#if defined key_agrif + USE agrif_oce_interp +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC dyn_nxt ! routine called by step.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_nxt ( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE dyn_nxt *** + !! + !! ** Purpose : Finalize after horizontal velocity. Apply the boundary + !! condition on the after velocity, achieve the time stepping + !! by applying the Asselin filter on now fields and swapping + !! the 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 time filter applied and swap of the dynamics + !! arrays to start the next time step: + !! (ub,vb) = (un,vn) + atfp [ (ub,vb) + (ua,va) - 2 (un,vn) ] + !! (un,vn) = (ua,va). + !! Note that with flux form advection and non linear free surface, + !! the time filter is applied on thickness weighted velocity. + !! As a result, dyn_nxt MUST be called after tra_nxt. + !! + !! ** Action : ub,vb filtered before horizontal velocity of next time-step + !! un,vn now horizontal velocity of next time-step + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikt ! local integers + REAL(wp) :: zue3a, zue3n, zue3b, zuf, zcoef ! local scalars + REAL(wp) :: zve3a, zve3n, zve3b, zvf, z1_2dt ! - - + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zue, zve + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zutau, zvtau + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3u_f, ze3v_f, zua, zva + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_nxt') + 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_nxt : time stepping' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + IF ( ln_dynspg_ts ) THEN + ! Ensure below that barotropic velocities match time splitting estimate + ! Compute actual transport and replace it with ts estimate at "after" time step + zue(:,:) = e3u_a(:,:,1) * ua(:,:,1) * umask(:,:,1) + zve(:,:) = e3v_a(:,:,1) * va(:,:,1) * vmask(:,:,1) + DO jk = 2, jpkm1 + zue(:,:) = zue(:,:) + e3u_a(:,:,jk) * ua(:,:,jk) * umask(:,:,jk) + zve(:,:) = zve(:,:) + e3v_a(:,:,jk) * va(:,:,jk) * vmask(:,:,jk) + END DO + DO jk = 1, jpkm1 + ua(:,:,jk) = ( ua(:,:,jk) - zue(:,:) * r1_hu_a(:,:) + ua_b(:,:) ) * umask(:,:,jk) + va(:,:,jk) = ( va(:,:,jk) - zve(:,:) * r1_hv_a(:,:) + va_b(:,:) ) * vmask(:,:,jk) + 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 + un(:,:,jk) = ( un(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:) + un_b(:,:) )*umask(:,:,jk) + vn(:,:,jk) = ( vn(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:) + vn_b(:,:) )*vmask(:,:,jk) + END DO + ENDIF + ENDIF + + ! Update after velocity on domain lateral boundaries + ! -------------------------------------------------- +# if defined key_agrif + CALL Agrif_dyn( kt ) !* AGRIF zoom boundaries +# endif + ! + CALL lbc_lnk_multi( 'dynnxt', ua, 'U', -1., va, 'V', -1. ) !* local domain boundaries + ! + ! !* BDY open boundaries + IF( ln_bdy .AND. ln_dynspg_exp ) CALL bdy_dyn( kt ) + IF( ln_bdy .AND. ln_dynspg_ts ) CALL bdy_dyn( kt, dyn3d_only=.true. ) + +!!$ Do we need a call to bdy_vol here?? + ! + IF( l_trddyn ) THEN ! prepare the atf trend computation + some diagnostics + z1_2dt = 1._wp / (2. * rdt) ! Euler or leap-frog time step + IF( neuler == 0 .AND. kt == nit000 ) z1_2dt = 1._wp / rdt + ! + ! ! Kinetic energy and Conversion + IF( ln_KE_trd ) CALL trd_dyn( ua, va, jpdyn_ken, kt ) + ! + IF( ln_dyn_trd ) THEN ! 3D output: total momentum trends + zua(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) * z1_2dt + zva(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) * z1_2dt + CALL iom_put( "utrd_tot", zua ) ! total momentum trends, except the asselin time filter + CALL iom_put( "vtrd_tot", zva ) + ENDIF + ! + zua(:,:,:) = un(:,:,:) ! save the now velocity before the asselin filter + zva(:,:,:) = vn(:,:,:) ! (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( neuler == 0 .AND. kt == nit000 ) THEN !* Euler at first time-step: only swap + DO jk = 1, jpkm1 + ub(:,:,jk) = un(:,:,jk) ! ub <-- un + vb(:,:,jk) = vn(:,:,jk) + un(:,:,jk) = ua(:,:,jk) ! un <-- ua + vn(:,:,jk) = va(:,:,jk) + END DO + IF( .NOT.ln_linssh ) THEN ! e3._b <-- e3._n +!!gm BUG ???? I don't understand why it is not : e3._n <-- e3._a + DO jk = 1, jpkm1 +! e3t_b(:,:,jk) = e3t_n(:,:,jk) +! e3u_b(:,:,jk) = e3u_n(:,:,jk) +! e3v_b(:,:,jk) = e3v_n(:,:,jk) + ! + e3t_n(:,:,jk) = e3t_a(:,:,jk) + e3u_n(:,:,jk) = e3u_a(:,:,jk) + e3v_n(:,:,jk) = e3v_a(:,:,jk) + END DO +!!gm BUG end + ENDIF + ! + + ELSE !* Leap-Frog : Asselin filter and swap + ! ! =============! + IF( ln_linssh ) THEN ! Fixed volume ! + ! ! =============! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) ) + zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) ) + ! + ub(ji,jj,jk) = zuf ! ub <-- filtered velocity + vb(ji,jj,jk) = zvf + un(ji,jj,jk) = ua(ji,jj,jk) ! un <-- ua + vn(ji,jj,jk) = va(ji,jj,jk) + END DO + END DO + END DO + ! ! ================! + ELSE ! Variable volume ! + ! ! ================! + ! Before scale factor at t-points + ! (used as a now filtered scale factor until the swap) + ! ---------------------------------------------------- + DO jk = 1, jpkm1 + e3t_b(:,:,jk) = e3t_n(:,:,jk) + atfp * ( e3t_b(:,:,jk) - 2._wp * e3t_n(:,:,jk) + e3t_a(:,:,jk) ) + END DO + ! Add volume filter correction: compatibility with tracer advection scheme + ! => time filter + conservation correction (only at the first level) + zcoef = atfp * rdt * r1_rau0 + + DO jk = 1, jpkm1 + e3t_b(:,:,jk) = e3t_b(:,:,jk) - zcoef * ( emp_b(:,:) - emp(:,:) ) * tmask(:,:,jk) & + & * e3t_n(:,:,jk) / ( ht_n(:,:) + 1._wp - ssmask(:,:) ) + END DO + + IF ( ln_rnf ) THEN + DO jk = 1, jpkm1 + e3t_b(:,:,jk) = e3t_b(:,:,jk) + zcoef * ( rnf_b(:,:) - rnf(:,:) ) * tmask(:,:,jk) & + & * e3t_n(:,:,jk) / ( ht_n(:,:) + 1._wp - ssmask(:,:) ) + END DO + ENDIF + + IF ( ln_isf ) THEN + DO jk = 1, jpkm1 + e3t_b(:,:,jk) = e3t_b(:,:,jk) - zcoef * ( fwfisf_b(:,:) - fwfisf(:,:) ) * tmask(:,:,jk) & + & * e3t_n(:,:,jk) / ( ht_n(:,:) + 1._wp - ssmask(:,:) ) + END DO + ENDIF + ! + IF( ln_dynadv_vec ) THEN ! Asselin filter applied on velocity + ! Before filtered scale factor at (u/v)-points + CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' ) + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zuf = un(ji,jj,jk) + atfp * ( ub(ji,jj,jk) - 2._wp * un(ji,jj,jk) + ua(ji,jj,jk) ) + zvf = vn(ji,jj,jk) + atfp * ( vb(ji,jj,jk) - 2._wp * vn(ji,jj,jk) + va(ji,jj,jk) ) + ! + ub(ji,jj,jk) = zuf ! ub <-- filtered velocity + vb(ji,jj,jk) = zvf + un(ji,jj,jk) = ua(ji,jj,jk) ! un <-- ua + vn(ji,jj,jk) = va(ji,jj,jk) + END DO + END DO + END DO + ! + ELSE ! Asselin filter applied on thickness weighted velocity + ! + ALLOCATE( ze3u_f(jpi,jpj,jpk) , ze3v_f(jpi,jpj,jpk) ) + ! Before filtered scale factor at (u/v)-points stored in ze3u_f, ze3v_f + CALL dom_vvl_interpol( e3t_b(:,:,:), ze3u_f, 'U' ) + CALL dom_vvl_interpol( e3t_b(:,:,:), ze3v_f, 'V' ) + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zue3a = e3u_a(ji,jj,jk) * ua(ji,jj,jk) + zve3a = e3v_a(ji,jj,jk) * va(ji,jj,jk) + zue3n = e3u_n(ji,jj,jk) * un(ji,jj,jk) + zve3n = e3v_n(ji,jj,jk) * vn(ji,jj,jk) + zue3b = e3u_b(ji,jj,jk) * ub(ji,jj,jk) + zve3b = e3v_b(ji,jj,jk) * vb(ji,jj,jk) + ! + zuf = ( zue3n + atfp * ( zue3b - 2._wp * zue3n + zue3a ) ) / ze3u_f(ji,jj,jk) + zvf = ( zve3n + atfp * ( zve3b - 2._wp * zve3n + zve3a ) ) / ze3v_f(ji,jj,jk) + ! + ub(ji,jj,jk) = zuf ! ub <-- filtered velocity + vb(ji,jj,jk) = zvf + un(ji,jj,jk) = ua(ji,jj,jk) ! un <-- ua + vn(ji,jj,jk) = va(ji,jj,jk) + END DO + END DO + END DO + e3u_b(:,:,1:jpkm1) = ze3u_f(:,:,1:jpkm1) ! e3u_b <-- filtered scale factor + e3v_b(:,:,1:jpkm1) = ze3v_f(:,:,1:jpkm1) + ! + DEALLOCATE( ze3u_f , ze3v_f ) + ENDIF + ! + ENDIF + ! + IF( ln_dynspg_ts .AND. ln_bt_fw ) THEN + ! Revert "before" velocities to time split estimate + ! Doing it here also means that asselin filter contribution is removed + zue(:,:) = e3u_b(:,:,1) * ub(:,:,1) * umask(:,:,1) + zve(:,:) = e3v_b(:,:,1) * vb(:,:,1) * vmask(:,:,1) + DO jk = 2, jpkm1 + zue(:,:) = zue(:,:) + e3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) + zve(:,:) = zve(:,:) + e3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk) + END DO + DO jk = 1, jpkm1 + ub(:,:,jk) = ub(:,:,jk) - (zue(:,:) * r1_hu_n(:,:) - un_b(:,:)) * umask(:,:,jk) + vb(:,:,jk) = vb(:,:,jk) - (zve(:,:) * r1_hv_n(:,:) - vn_b(:,:)) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF ! neuler =/0 + ! + ! 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 + ! + ! + IF(.NOT.ln_linssh ) THEN + hu_b(:,:) = e3u_b(:,:,1) * umask(:,:,1) + hv_b(:,:) = e3v_b(:,:,1) * vmask(:,:,1) + DO jk = 2, jpkm1 + hu_b(:,:) = hu_b(:,:) + e3u_b(:,:,jk) * umask(:,:,jk) + hv_b(:,:) = hv_b(:,:) + e3v_b(:,:,jk) * vmask(:,:,jk) + END DO + r1_hu_b(:,:) = ssumask(:,:) / ( hu_b(:,:) + 1._wp - ssumask(:,:) ) + r1_hv_b(:,:) = ssvmask(:,:) / ( hv_b(:,:) + 1._wp - ssvmask(:,:) ) + ENDIF + ! + un_b(:,:) = e3u_a(:,:,1) * un(:,:,1) * umask(:,:,1) + ub_b(:,:) = e3u_b(:,:,1) * ub(:,:,1) * umask(:,:,1) + vn_b(:,:) = e3v_a(:,:,1) * vn(:,:,1) * vmask(:,:,1) + vb_b(:,:) = e3v_b(:,:,1) * vb(:,:,1) * vmask(:,:,1) + DO jk = 2, jpkm1 + un_b(:,:) = un_b(:,:) + e3u_a(:,:,jk) * un(:,:,jk) * umask(:,:,jk) + ub_b(:,:) = ub_b(:,:) + e3u_b(:,:,jk) * ub(:,:,jk) * umask(:,:,jk) + vn_b(:,:) = vn_b(:,:) + e3v_a(:,:,jk) * vn(:,:,jk) * vmask(:,:,jk) + vb_b(:,:) = vb_b(:,:) + e3v_b(:,:,jk) * vb(:,:,jk) * vmask(:,:,jk) + END DO + un_b(:,:) = un_b(:,:) * r1_hu_a(:,:) + vn_b(:,:) = vn_b(:,:) * r1_hv_a(:,:) + ub_b(:,:) = ub_b(:,:) * r1_hu_b(:,:) + vb_b(:,:) = vb_b(:,:) * r1_hv_b(:,:) + ! + IF( .NOT.ln_dynspg_ts ) THEN ! output the barotropic currents + CALL iom_put( "ubar", un_b(:,:) ) + CALL iom_put( "vbar", vn_b(:,:) ) + ENDIF + IF( l_trddyn ) THEN ! 3D output: asselin filter trends on momentum + zua(:,:,:) = ( ub(:,:,:) - zua(:,:,:) ) * z1_2dt + zva(:,:,:) = ( vb(:,:,:) - zva(:,:,:) ) * z1_2dt + CALL trd_dyn( zua, zva, jpdyn_atf, kt ) + ENDIF + ! + IF ( iom_use("utau") ) THEN + IF ( ln_drgice_imp.OR.ln_isfcav ) THEN + ALLOCATE(zutau(jpi,jpj)) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + jk = miku(ji,jj) + zutau(ji,jj) = utau(ji,jj) & + & + 0.5_wp * rau0 * (rCdU_top(ji+1,jj)+rCdU_top(ji,jj)) * ua(ji,jj,jk) + END DO + END DO + CALL lbc_lnk( 'dynnxt' , zutau, 'U', -1.) + 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 = 2, jpjm1 + DO ji = 2, jpim1 + jk = mikv(ji,jj) + zvtau(ji,jj) = vtau(ji,jj) & + & + 0.5_wp * rau0 * (rCdU_top(ji,jj+1)+rCdU_top(ji,jj)) * va(ji,jj,jk) + END DO + END DO + CALL lbc_lnk( 'dynnxt' , zvtau, 'V', -1.) + CALL iom_put( "vtau", zvtau(:,:) ) + DEALLOCATE(zvtau) + ELSE + CALL iom_put( "vtau", vtau(:,:) ) + ENDIF + ENDIF + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=un, clinfo1=' nxt - Un: ', mask1=umask, & + & tab3d_2=vn, clinfo2=' Vn: ' , mask2=vmask ) + ! + IF( ln_dynspg_ts ) DEALLOCATE( zue, zve ) + IF( l_trddyn ) DEALLOCATE( zua, zva ) + IF( ln_timing ) CALL timing_stop('dyn_nxt') + ! + END SUBROUTINE dyn_nxt + + !!========================================================================= +END MODULE dynnxt diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynspg.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynspg.F90 new file mode 100644 index 0000000..0ac75e0 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynspg.F90 @@ -0,0 +1,240 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 dynspg_exp ! surface pressure gradient (dyn_spg_exp routine) + USE dynspg_ts ! surface pressure gradient (dyn_spg_ts routine) + USE sbctide ! + USE updtide ! + 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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_spg( kt ) + !!---------------------------------------------------------------------- + !! *** 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/rau0 di[apr] = 0.5*grav di[ssh_ib+ssh_ibb] + !! apgv = - 1/rau0 dj[apr] = 0.5*grav dj[ssh_ib+ssh_ibb] + !! Note that as all external forcing a time averaging over a two rdt + !! period is used to prevent the divergence of odd and even time step. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z2dt, zg_2, zintp, zgrau0r, zld ! local scalars + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zpice + REAL(wp), 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(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + 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 ) THEN ! embedded sea-ice + ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + spgu(ji,jj) = 0._wp + spgv(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 = 2, jpjm1 ! gradient of Patm using inverse barometer ssh + DO ji = fs_2, fs_jpim1 ! vector opt. + spgu(ji,jj) = spgu(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) + spgv(ji,jj) = spgv(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 + ! + CALL upd_tide( kt ) ! update tide potential + ! + DO jj = 2, jpjm1 ! add tide potential forcing + DO ji = fs_2, fs_jpim1 ! vector opt. + spgu(ji,jj) = spgu(ji,jj) + grav * ( pot_astro(ji+1,jj) - pot_astro(ji,jj) ) * r1_e1u(ji,jj) + spgv(ji,jj) = spgv(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 = 2, jpjm1 ! add scalar approximation for load potential + DO ji = fs_2, fs_jpim1 ! vector opt. + spgu(ji,jj) = spgu(ji,jj) + zld * ( sshn(ji+1,jj) - sshn(ji,jj) ) * r1_e1u(ji,jj) + spgv(ji,jj) = spgv(ji,jj) + zld * ( sshn(ji,jj+1) - sshn(ji,jj) ) * 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 ) + zgrau0r = - grav * r1_rau0 + zpice(:,:) = ( zintp * snwice_mass(:,:) + ( 1.- zintp ) * snwice_mass_b(:,:) ) * zgrau0r + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + spgu(ji,jj) = spgu(ji,jj) + ( zpice(ji+1,jj) - zpice(ji,jj) ) * r1_e1u(ji,jj) + spgv(ji,jj) = spgv(ji,jj) + ( zpice(ji,jj+1) - zpice(ji,jj) ) * r1_e2v(ji,jj) + END DO + END DO + DEALLOCATE( zpice ) + ENDIF + ! + DO jk = 1, jpkm1 !== Add all terms to the general trend + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj)* umask(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj)* vmask(ji,jj,jk) + 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 ) ! explicit + CASE ( np_TS ) ; CALL dyn_spg_ts ( kt ) ! time-splitting + END SELECT + ! + IF( l_trddyn ) THEN ! save the surface pressure gradient trends for further diagnostics + ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_spg, kt ) + DEALLOCATE( ztrdu , ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' spg - Ua: ', mask1=umask, & + & tab3d_2=va, 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_baro , 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 + ! + REWIND( numnam_ref ) ! Namelist namdyn_spg in reference namelist : Free surface + READ ( numnam_ref, namdyn_spg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_spg in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namdyn_spg in configuration namelist : Free surface + 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_baro used to allocate some arrays later on + ENDIF + ! + END SUBROUTINE dyn_spg_init + + !!====================================================================== +END MODULE dynspg diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynspg_exp.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynspg_exp.F90 new file mode 100644 index 0000000..4971214 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynspg_exp.F90 @@ -0,0 +1,95 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_spg_exp( kt ) + !!---------------------------------------------------------------------- + !! *** 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 : + !! (ua,va) = (ua,va) + (spgu,spgv) + !! where spgu = -1/rau0 d/dx(ps) = -g/e1u di( sshn ) + !! spgv = -1/rau0 d/dy(ps) = -g/e2v dj( sshn ) + !! + !! ** Action : (ua,va) trend of horizontal velocity increased by + !! the surf. pressure gradient trend + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + 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)' + ! + spgu(:,:) = 0._wp ; spgv(:,:) = 0._wp + ! + IF( .NOT.ln_linssh .AND. lwp ) WRITE(numout,*) ' non linear free surface: spg is included in dynhpg' + ENDIF + + IF( ln_linssh ) THEN !* linear free surface : add the surface pressure gradient trend + ! + DO jj = 2, jpjm1 ! now surface pressure gradient + DO ji = fs_2, fs_jpim1 ! vector opt. + spgu(ji,jj) = - grav * ( sshn(ji+1,jj) - sshn(ji,jj) ) * r1_e1u(ji,jj) + spgv(ji,jj) = - grav * ( sshn(ji,jj+1) - sshn(ji,jj) ) * r1_e2v(ji,jj) + END DO + END DO + ! + DO jk = 1, jpkm1 ! Add it to the general trend + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) + spgu(ji,jj) + va(ji,jj,jk) = va(ji,jj,jk) + spgv(ji,jj) + END DO + END DO + END DO + ! + ENDIF + ! + END SUBROUTINE dyn_spg_exp + + !!====================================================================== +END MODULE dynspg_exp diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynspg_ts.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynspg_ts.F90 new file mode 100644 index 0000000..e6ad2ff --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynspg_ts.F90 @@ -0,0 +1,1606 @@ +MODULE dynspg_ts + + !! Includes ROMS wd scheme with diagnostic outputs ; un and ua 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 zdf_oce ! vertical physics: variables + USE zdfdrg ! vertical physics: top/bottom drag coef. + USE sbcisf ! ice shelf variable (fwfisf) + 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 sbctide ! tides + USE updtide ! tide potential + USE sbcwave ! surface wave +#if defined key_agrif + USE agrif_oce_interp ! agrif + USE agrif_oce +#endif +#if defined key_asminc + USE asminc ! Assimilation increment +#endif + ! + 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_baro <= 2.5 nn_baro + REAL(wp),SAVE :: rdtbt ! Barotropic time step + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:) :: wgtbtp1, wgtbtp2 ! 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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_baro), wgtbtp2(3*nn_baro), 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 ) + !!---------------------------------------------------------------------- + !! + !! ** 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" : ssha + !! -Update filtered barotropic velocities at step "n+1" : ua_b, va_b + !! -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. + !! - (ua, va) momentum trend updated with barotropic component. + !! + !! References : Shchepetkin and McWilliams, Ocean Modelling, 2005. + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + 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_2dt_b, z1_hu, z1_hv ! local scalars + REAL(wp) :: za0, za1, za2, za3 ! - - + REAL(wp) :: zztmp, zldg ! - - + REAL(wp) :: zhu_bck, zhv_bck, zhdiv ! - - + REAL(wp) :: zun_save, zvn_save ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zu_trd, zu_frc, zu_spg, zssh_frc + 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) :: zhU, zhV ! fluxes + ! + 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 + !!---------------------------------------------------------------------- + ! + 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 + IF( kt == nit000 .AND. neuler == 0 ) THEN ; r1_2dt_b = 1._wp / ( rdt ) + ELSE ; r1_2dt_b = 1._wp / ( 2._wp * rdt ) + ENDIF + ! + 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_baro + 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( neuler == 0 ) ll_init=.TRUE. + ! + IF( ln_bt_fw .OR. neuler == 0 ) 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 ) + ! + ENDIF + ! + ! If forward start at previous time step, and centered integration, + ! then update averaging weights: + IF (.NOT.ln_bt_fw .AND.( neuler==0 .AND. kt==nit000+1 ) ) THEN + ll_fw_start=.FALSE. + CALL ts_wgt( ln_bt_av, ll_fw_start, icycle, wgtbtp1, wgtbtp2 ) + 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_n(:,:,:) * ua(:,:,:) * umask(:,:,:) , DIM=3 ) * r1_hu_n(:,:) + zv_frc(:,:) = SUM( e3v_n(:,:,:) * va(:,:,:) * vmask(:,:,:) , DIM=3 ) * r1_hv_n(:,:) + ! + ! + ! != Ua => baroclinic trend =! (remove its vertical mean) + DO jk = 1, jpkm1 ! ------------------------ ! + ua(:,:,jk) = ( ua(:,:,jk) - zu_frc(:,:) ) * umask(:,:,jk) + va(:,:,jk) = ( va(:,:,jk) - 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 and pressure gradient trends =! + ! ! ------------------------------------------------- ! + ! + IF( kt == nit000 .OR. .NOT. ln_linssh ) CALL dyn_cor_2D_init ! 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 + ! + ! !* 2D Coriolis trends + zhU(:,:) = un_b(:,:) * hu_n(:,:) * e2u(:,:) ! now fluxes + zhV(:,:) = vn_b(:,:) * hv_n(:,:) * e1v(:,:) ! NB: FULL domain : put a value in last row and column + ! + CALL dyn_cor_2d( hu_n, hv_n, un_b, vn_b, zhU, zhV, & ! <<== in + & zu_trd, zv_trd ) ! ==>> out + ! + IF( .NOT.ln_linssh ) THEN !* surface pressure gradient (variable volume only) + ! + IF( ln_wd_il ) THEN ! W/D : limiter applied to spgspg + CALL wad_spg( sshn, zcpx, zcpy ) ! Calculating W/D gravity filters, zcpx and zcpy + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! SPG with the application of W/D gravity filters + zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) & + & * r1_e1u(ji,jj) * zcpx(ji,jj) * wdrampu(ji,jj) !jth + zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) & + & * r1_e2v(ji,jj) * zcpy(ji,jj) * wdrampv(ji,jj) !jth + END DO + END DO + ELSE ! now suface pressure gradient + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zu_trd(ji,jj) = zu_trd(ji,jj) - grav * ( sshn(ji+1,jj ) - sshn(ji ,jj ) ) * r1_e1u(ji,jj) + zv_trd(ji,jj) = zv_trd(ji,jj) - grav * ( sshn(ji ,jj+1) - sshn(ji ,jj ) ) * r1_e2v(ji,jj) + END DO + END DO + ENDIF + ! + ENDIF + ! + DO jj = 2, jpjm1 ! Remove coriolis term (and possibly spg) from barotropic trend + DO ji = fs_2, fs_jpim1 + 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 + ! + ! != Add bottom stress contribution from baroclinic velocities =! + ! ! ----------------------------------------------------------- ! + CALL dyn_drg_init( zu_frc, zv_frc, zCdU_u, zCdU_v ) ! also provide the barotropic drag coefficients + ! + ! != 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 atmospheric pressure forcing =! + ! ! ---------------------------------- ! + IF( ln_bt_fw ) THEN ! Add wind forcing + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zu_frc(ji,jj) = zu_frc(ji,jj) + r1_rau0 * utau(ji,jj) * r1_hu_n(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) + r1_rau0 * vtau(ji,jj) * r1_hv_n(ji,jj) + END DO + END DO + ELSE + zztmp = r1_rau0 * r1_2 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zu_frc(ji,jj) = zu_frc(ji,jj) + zztmp * ( utau_b(ji,jj) + utau(ji,jj) ) * r1_hu_n(ji,jj) + zv_frc(ji,jj) = zv_frc(ji,jj) + zztmp * ( vtau_b(ji,jj) + vtau(ji,jj) ) * r1_hv_n(ji,jj) + 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) + zssh_frc(:,:) = r1_rau0 * ( emp(:,:) - rnf(:,:) + fwfisf(:,:) ) + ELSE ! CENTRED integration: use kt-1/2 + kt+1/2 fluxes (NOW) + zztmp = r1_rau0 * r1_2 + zssh_frc(:,:) = zztmp * ( emp(:,:) + emp_b(:,:) - rnf(:,:) - rnf_b(:,:) + fwfisf(:,:) + fwfisf_b(:,:) ) + ENDIF + ! != Add Stokes drift divergence =! (if exist) + IF( ln_sdw ) THEN ! ----------------------------- ! + zssh_frc(:,:) = zssh_frc(:,:) + div_sd(:,:) + ENDIF + ! +#if defined key_asminc + ! != Add the IAU weighted SSH increment =! + ! ! ------------------------------------ ! + IF( lk_asminc .AND. ln_sshinc .AND. ln_asmiau ) THEN + zssh_frc(:,:) = zssh_frc(:,:) - ssh_iau(:,:) + ENDIF +#endif + ! != Fill boundary data arrays for AGRIF + ! ! ------------------------------------ +#if defined key_agrif + IF( .NOT.Agrif_Root() ) CALL agrif_dta_ts( kt ) +#endif + ! + ! ----------------------------------------------------------------------- + ! 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_n(:,:) + zhvp2_e(:,:) = hv_n(:,:) + zhtp2_e(:,:) = ht_n(:,:) + ENDIF + ! + IF (ln_bt_fw) THEN ! FORWARD integration: start from NOW fields + sshn_e(:,:) = sshn(:,:) + un_e (:,:) = un_b(:,:) + vn_e (:,:) = vn_b(:,:) + ! + hu_e (:,:) = hu_n(:,:) + hv_e (:,:) = hv_n(:,:) + hur_e (:,:) = r1_hu_n(:,:) + hvr_e (:,:) = r1_hv_n(:,:) + ELSE ! CENTRED integration: start from BEFORE fields + sshn_e(:,:) = sshb(:,:) + un_e (:,:) = ub_b(:,:) + vn_e (:,:) = vb_b(:,:) + ! + hu_e (:,:) = hu_b(:,:) + hv_e (:,:) = hv_b(:,:) + hur_e (:,:) = r1_hu_b(:,:) + hvr_e (:,:) = r1_hv_b(:,:) + ENDIF + ! + ! Initialize sums: + ua_b (:,:) = 0._wp ! After barotropic velocities (or transport if flux form) + va_b (:,:) = 0._wp + ssha (:,:) = 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, kt_offset= noffset+1 ) + IF( ln_tide_pot .AND. ln_tide ) CALL upd_tide ( kt, kit=jn, kt_offset= noffset ) + ! + ! !== 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) + DO jj = 1, jpj + DO ji = 1, jpim1 ! 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 = 1, jpjm1 ! not jpj-row + DO ji = 1, jpi + 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) + zhU(1:jpim1,1:jpj ) = e2u(1:jpim1,1:jpj ) * ua_e(1:jpim1,1:jpj ) * zhup2_e(1:jpim1,1:jpj ) ! not jpi-column + zhV(1:jpi ,1:jpjm1) = e1v(1:jpi ,1:jpjm1) * va_e(1:jpi ,1:jpjm1) * zhvp2_e(1:jpi ,1:jpjm1) ! not jpj-row + ! +#if defined key_agrif + ! Set fluxes during predictor step to ensure volume conservation + IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) THEN + IF( l_Westedge ) THEN + DO jj = 1, jpj + zhU(2:nbghostcells+1,jj) = ubdy_w(1:nbghostcells,jj) * e2u(2:nbghostcells+1,jj) + zhV(2:nbghostcells+1,jj) = vbdy_w(1:nbghostcells,jj) * e1v(2:nbghostcells+1,jj) + END DO + ENDIF + IF( l_Eastedge ) THEN + DO jj=1,jpj + zhU(nlci-nbghostcells-1:nlci-2,jj) = ubdy_e(1:nbghostcells,jj) * e2u(nlci-nbghostcells-1:nlci-2,jj) + zhV(nlci-nbghostcells :nlci-1,jj) = vbdy_e(1:nbghostcells,jj) * e1v(nlci-nbghostcells :nlci-1,jj) + END DO + ENDIF + IF( l_Southedge ) THEN + DO ji=1,jpi + zhV(ji,2:nbghostcells+1) = vbdy_s(ji,1:nbghostcells) * e1v(ji,2:nbghostcells+1) + zhU(ji,2:nbghostcells+1) = ubdy_s(ji,1:nbghostcells) * e2u(ji,2:nbghostcells+1) + END DO + ENDIF + IF( l_Northedge ) THEN + DO ji=1,jpi + zhV(ji,nlcj-nbghostcells-1:nlcj-2) = vbdy_n(ji,1:nbghostcells) * e1v(ji,nlcj-nbghostcells-1:nlcj-2) + zhU(ji,nlcj-nbghostcells :nlcj-1) = ubdy_n(ji,1:nbghostcells) * e2u(ji,nlcj-nbghostcells :nlcj-1) + END DO + ENDIF + ENDIF +#endif + IF( ln_wd_il ) CALL wad_lmt_bt(zhU, zhV, sshn_e, zssh_frc, rdtbt) !!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 = 2, jpjm1 ! INNER domain + DO ji = 2, jpim1 + 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) - rdtbt * ( zssh_frc(ji,jj) + zhdiv ) ) * ssmask(ji,jj) + END DO + END DO + ! + CALL lbc_lnk_multi( 'dynspg_ts', ssha_e, 'T', 1._wp, zhU, 'U', -1._wp, zhV, 'V', -1._wp ) + ! + ! ! 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 + zuwdav2(1:jpim1,1:jpj ) = zuwdav2(1:jpim1,1:jpj ) + za2 * zuwdmask(1:jpim1,1:jpj ) ! not jpi-column + zvwdav2(1:jpi ,1:jpjm1) = zvwdav2(1:jpi ,1:jpjm1) + za2 * zvwdmask(1:jpi ,1:jpjm1) ! not jpj-row + END IF + ! + ! Duplicate sea level across open boundaries (this is only cosmetic if linssh=T) + IF( ln_bdy ) CALL bdy_ssh( ssha_e ) +#if defined key_agrif + IF( .NOT.Agrif_Root() ) CALL agrif_ssh_ts( jn ) +#endif + ! + ! Sea Surface Height at u-,v-points (vvl case only) + IF( .NOT.ln_linssh ) THEN + DO jj = 2, jpjm1 ! INNER domain, will be extended to whole domain later + DO ji = 2, jpim1 ! NO Vector Opt. + zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & + & + e1e2t(ji+1,jj ) * ssha_e(ji+1,jj ) ) + zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji ,jj ) * ssha_e(ji ,jj ) & + & + e1e2t(ji ,jj+1) * ssha_e(ji ,jj+1) ) + 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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 + zu_spg(2:jpim1,2:jpjm1) = zu_spg(2:jpim1,2:jpjm1) * zcpx(2:jpim1,2:jpjm1) + zv_spg(2:jpim1,2:jpjm1) = zv_spg(2:jpim1,2:jpjm1) * zcpy(2:jpim1,2:jpjm1) + 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( 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua_e(ji,jj) = ( un_e(ji,jj) & + & + rdtbt * ( zu_spg(ji,jj) & + & + zu_trd(ji,jj) & + & + zu_frc(ji,jj) ) & + & ) * ssumask(ji,jj) + + va_e(ji,jj) = ( vn_e(ji,jj) & + & + rdtbt * ( zv_spg(ji,jj) & + & + zv_trd(ji,jj) & + & + zv_frc(ji,jj) ) & + & ) * ssvmask(ji,jj) + END DO + END DO + ! + ELSE !* Flux form + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! ! 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) & + & + rdtbt * ( zhu_bck * zu_spg (ji,jj) & ! + & + zhup2_e(ji,jj) * zu_trd (ji,jj) & ! + & + hu_n (ji,jj) * zu_frc (ji,jj) ) ) * z1_hu + ! + va_e(ji,jj) = ( hv_e (ji,jj) * vn_e (ji,jj) & + & + rdtbt * ( zhv_bck * zv_spg (ji,jj) & ! + & + zhvp2_e(ji,jj) * zv_trd (ji,jj) & ! + & + hv_n (ji,jj) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua_e(ji,jj) = ua_e(ji,jj) /(1.0 - rdtbt * zCdU_u(ji,jj) * hur_e(ji,jj)) + va_e(ji,jj) = va_e(ji,jj) /(1.0 - rdtbt * 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) + hu_e (2:jpim1,2:jpjm1) = hu_0(2:jpim1,2:jpjm1) + zsshu_a(2:jpim1,2:jpjm1) + hur_e(2:jpim1,2:jpjm1) = ssumask(2:jpim1,2:jpjm1) / ( hu_e(2:jpim1,2:jpjm1) + 1._wp - ssumask(2:jpim1,2:jpjm1) ) + hv_e (2:jpim1,2:jpjm1) = hv_0(2:jpim1,2:jpjm1) + zsshv_a(2:jpim1,2:jpjm1) + hvr_e(2:jpim1,2:jpjm1) = ssvmask(2:jpim1,2:jpjm1) / ( hv_e(2:jpim1,2:jpjm1) + 1._wp - ssvmask(2:jpim1,2:jpjm1) ) + CALL lbc_lnk_multi( '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_multi( '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 ) +#if defined key_agrif + IF( .NOT.Agrif_Root() ) CALL agrif_dyn_ts( jn ) ! Agrif +#endif + ! !* 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 + ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) + va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) + ELSE ! Sum transports + IF ( .NOT.ln_wd_dl ) THEN + ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) * hu_e (:,:) + va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) * hv_e (:,:) + ELSE + ua_b (:,:) = ua_b (:,:) + za1 * ua_e (:,:) * hu_e (:,:) * zuwdmask(:,:) + va_b (:,:) = va_b (:,:) + za1 * va_e (:,:) * hv_e (:,:) * zvwdmask(:,:) + END IF + ENDIF + ! ! Sum sea level + ssha(:,:) = ssha(:,:) + 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. neuler==0 ) ) THEN + DO jj = 1, jpj + DO ji = 1, jpi + 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 - atfp * un_bf(ji,jj) ) + vn_adv(ji,jj) = r1_2 * ( vb2_b(ji,jj) + zvn_save - atfp * vn_bf(ji,jj) ) + ! ! Update corrective fluxes for next time step + un_bf(ji,jj) = atfp * un_bf(ji,jj) + ( zun_save - ub2_b(ji,jj) ) + vn_bf(ji,jj) = 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 + ua(:,:,jk) = ua(:,:,jk) + ( ua_b(:,:) - ub_b(:,:) ) * r1_2dt_b + va(:,:,jk) = va(:,:,jk) + ( va_b(:,:) - vb_b(:,:) ) * r1_2dt_b + END DO + ELSE + ! At this stage, ssha has been corrected: compute new depths at velocity points + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! NO Vector Opt. + zsshu_a(ji,jj) = r1_2 * ssumask(ji,jj) * r1_e1e2u(ji,jj) & + & * ( e1e2t(ji ,jj) * ssha(ji ,jj) & + & + e1e2t(ji+1,jj) * ssha(ji+1,jj) ) + zsshv_a(ji,jj) = r1_2 * ssvmask(ji,jj) * r1_e1e2v(ji,jj) & + & * ( e1e2t(ji,jj ) * ssha(ji,jj ) & + & + e1e2t(ji,jj+1) * ssha(ji,jj+1) ) + END DO + END DO + CALL lbc_lnk_multi( 'dynspg_ts', zsshu_a, 'U', 1._wp, zsshv_a, 'V', 1._wp ) ! Boundary conditions + ! + DO jk=1,jpkm1 + ua(:,:,jk) = ua(:,:,jk) + r1_hu_n(:,:) * ( ua_b(:,:) - ub_b(:,:) * hu_b(:,:) ) * r1_2dt_b + va(:,:,jk) = va(:,:,jk) + r1_hv_n(:,:) * ( va_b(:,:) - vb_b(:,:) * hv_b(:,:) ) * r1_2dt_b + END DO + ! Save barotropic velocities not transport: + ua_b(:,:) = ua_b(:,:) / ( hu_0(:,:) + zsshu_a(:,:) + 1._wp - ssumask(:,:) ) + va_b(:,:) = va_b(:,:) / ( 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 + un(:,:,jk) = ( un(:,:,jk) + un_adv(:,:)*r1_hu_n(:,:) - un_b(:,:) ) * umask(:,:,jk) + vn(:,:,jk) = ( vn(:,:,jk) + vn_adv(:,:)*r1_hv_n(:,:) - vn_b(:,:) ) * vmask(:,:,jk) + END DO + + IF ( ln_wd_dl .and. ln_wd_dl_bc) THEN + ! need to set lbc here because not done prior time averaging + CALL lbc_lnk_multi( 'dynspg_ts', zuwdav2, 'U', 1._wp, zvwdav2, 'V', 1._wp) + DO jk = 1, jpkm1 + un(:,:,jk) = ( un_adv(:,:)*r1_hu_n(:,:) & + & + zuwdav2(:,:)*(un(:,:,jk) - un_adv(:,:)*r1_hu_n(:,:)) ) * umask(:,:,jk) + vn(:,:,jk) = ( vn_adv(:,:)*r1_hv_n(:,:) & + & + zvwdav2(:,:)*(vn(:,:,jk) - vn_adv(:,:)*r1_hv_n(:,:)) ) * vmask(:,:,jk) + END DO + END IF + + + CALL iom_put( "ubar", un_adv(:,:)*r1_hu_n(:,:) ) ! barotropic i-current + CALL iom_put( "vbar", vn_adv(:,:)*r1_hv_n(:,:) ) ! barotropic i-current + ! +#if defined key_agrif + ! Save time integrated fluxes during child grid integration + ! (used to update coarse grid transports at next time step) + ! + IF( .NOT.Agrif_Root() .AND. ln_bt_fw ) THEN + IF( Agrif_NbStepint() == 0 ) THEN + ub2_i_b(:,:) = 0._wp + vb2_i_b(:,:) = 0._wp + END IF + ! + 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 +#endif + ! !* 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" , un_b ) ! Barotropic U Velocity + CALL iom_put( "baro_v" , vn_b ) ! 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_baro), INTENT(inout) :: zwgt1, & ! Primary weights + zwgt2 ! Secondary weights + + INTEGER :: jic, jn, ji ! temporary integers + REAL(wp) :: za1, za2 + !!---------------------------------------------------------------------- + + zwgt1(:) = 0._wp + zwgt2(:) = 0._wp + + ! Set time index when averaged value is requested + IF (ll_fw) THEN + jic = nn_baro + ELSE + jic = 2 * nn_baro + ENDIF + + ! Set primary weights: + IF (ll_av) THEN + ! Define simple boxcar window for primary weights + ! (width = nn_baro, centered around jic) + SELECT CASE ( nn_bt_flt ) + CASE( 0 ) ! No averaging + zwgt1(jic) = 1._wp + jpit = jic + + CASE( 1 ) ! Boxcar, width = nn_baro + DO jn = 1, 3*nn_baro + za1 = ABS(float(jn-jic))/float(nn_baro) + IF (za1 < 0.5_wp) THEN + zwgt1(jn) = 1._wp + jpit = jn + ENDIF + ENDDO + + CASE( 2 ) ! Boxcar, width = 2 * nn_baro + DO jn = 1, 3*nn_baro + za1 = ABS(float(jn-jic))/float(nn_baro) + 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. (neuler/=0) ) THEN !* Read the restart file + CALL iom_get( numror, jpdom_autoglo, 'ub2_b' , ub2_b (:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'vb2_b' , vb2_b (:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'un_bf' , un_bf (:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'vn_bf' , vn_bf (:,:), ldxios = lrxios ) + IF( .NOT.ln_bt_av ) THEN + CALL iom_get( numror, jpdom_autoglo, 'sshbb_e' , sshbb_e(:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'ubb_e' , ubb_e(:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'vbb_e' , vbb_e(:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'sshb_e' , sshb_e(:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'ub_e' , ub_e(:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'vb_e' , vb_e(:,:), ldxios = lrxios ) + ENDIF +#if defined key_agrif + ! Read time integrated fluxes + IF ( .NOT.Agrif_Root() ) THEN + CALL iom_get( numror, jpdom_autoglo, 'ub2_i_b' , ub2_i_b(:,:), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'vb2_i_b' , vb2_i_b(:,:), ldxios = lrxios ) + ENDIF +#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 +#if defined key_agrif + IF ( .NOT.Agrif_Root() ) THEN + ub2_i_b(:,:) = 0._wp ; vb2_i_b(:,:) = 0._wp ! used in the 1st update of agrif + ENDIF +#endif + ENDIF + ! + ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file + ! ! ------------------- + IF(lwp) WRITE(numout,*) '---- ts_rst ----' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'ub2_b' , ub2_b (:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'vb2_b' , vb2_b (:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'un_bf' , un_bf (:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'vn_bf' , vn_bf (:,:), ldxios = lwxios ) + ! + IF (.NOT.ln_bt_av) THEN + CALL iom_rstput( kt, nitrst, numrow, 'sshbb_e' , sshbb_e(:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'ubb_e' , ubb_e(:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'vbb_e' , vbb_e(:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sshb_e' , sshb_e(:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'ub_e' , ub_e(:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'vb_e' , vb_e(:,:), ldxios = lwxios ) + ENDIF +#if defined key_agrif + ! Save time integrated fluxes + IF ( .NOT.Agrif_Root() ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'ub2_i_b' , ub2_i_b(:,:), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'vb2_i_b' , vb2_i_b(:,:), ldxios = lwxios ) + ENDIF +#endif + IF( lwxios ) CALL iom_swap( cxios_context ) + 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 + INTEGER :: inum + !!---------------------------------------------------------------------- + ! + ! Max courant number for ext. grav. waves + ! + DO jj = 1, jpj + DO ji =1, jpi + 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(:,:) ) + CALL mpp_max( 'dynspg_ts', zcmax ) + + ! Estimate number of iterations to satisfy a max courant number= rn_bt_cmax + IF( ln_bt_auto ) nn_baro = CEILING( rdt / rn_bt_cmax * zcmax) + + rdtbt = rdt / REAL( nn_baro , wp ) + zcmax = zcmax * rdtbt + ! 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_baro ' + IF(lwp) WRITE(numout,*) ' Max. courant number allowed: ', rn_bt_cmax + ELSE + IF(lwp) WRITE(numout,*) ' ln_ts_auto=.false.: Use nn_baro in namelist nn_baro = ', nn_baro + ENDIF + + IF(ln_bt_av) THEN + IF(lwp) WRITE(numout,*) ' ln_bt_av =.true. ==> Time averaging over nn_baro 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 defined key_agrif + ! Restrict the use of Agrif to the forward case only +!!! IF( .NOT.ln_bt_fw .AND. .NOT.Agrif_Root() ) CALL ctl_stop( 'AGRIF not implemented if ln_bt_fw=.FALSE.' ) +#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_baro' + CASE( 2 ) ; IF(lwp) WRITE(numout,*) ' Boxcar: width = 2*nn_baro' + 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_baro = ', nn_baro + IF(lwp) WRITE(numout,*) ' Barotropic time step [s] is :', rdtbt + 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_baro !' ) + 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' ) + ! + IF( lwxios ) THEN +! define variables in restart file when writing with XIOS + CALL iom_set_rstw_var_active('ub2_b') + CALL iom_set_rstw_var_active('vb2_b') + CALL iom_set_rstw_var_active('un_bf') + CALL iom_set_rstw_var_active('vn_bf') + ! + IF (.NOT.ln_bt_av) THEN + CALL iom_set_rstw_var_active('sshbb_e') + CALL iom_set_rstw_var_active('ubb_e') + CALL iom_set_rstw_var_active('vbb_e') + CALL iom_set_rstw_var_active('sshb_e') + CALL iom_set_rstw_var_active('ub_e') + CALL iom_set_rstw_var_active('vb_e') + ENDIF +#if defined key_agrif + ! Save time integrated fluxes + IF ( .NOT.Agrif_Root() ) THEN + CALL iom_set_rstw_var_active('ub2_i_b') + CALL iom_set_rstw_var_active('vb2_i_b') + ENDIF +#endif + ENDIF + ! + END SUBROUTINE dyn_spg_ts_init + + + SUBROUTINE dyn_cor_2d_init + !!--------------------------------------------------------------------- + !! *** 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-F points (ht and zhf resp.) at each barotropic time step + !! + !! Compute zwz = f / ( height of the water colomn ) + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj, jk ! dummy loop indices + REAL(wp) :: z1_ht + REAL(wp), DIMENSION(jpi,jpj) :: zhf + !!---------------------------------------------------------------------- + ! + SELECT CASE( nvor_scheme ) + CASE( np_EEN ) != EEN scheme using e3f (energy & enstrophy scheme) + SELECT CASE( nn_een_e3f ) !* ff_f/e3 at F-point + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zwz(ji,jj) = ( ht_n(ji ,jj+1) + ht_n(ji+1,jj+1) + & + & ht_n(ji ,jj ) + ht_n(ji+1,jj ) ) * 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 = 1, jpjm1 + DO ji = 1, jpim1 + zwz(ji,jj) = ( ht_n (ji ,jj+1) + ht_n (ji+1,jj+1) & + & + ht_n (ji ,jj ) + ht_n (ji+1,jj ) ) & + & / ( MAX( 1._wp, ssmask(ji ,jj+1) + ssmask(ji+1,jj+1) & + & + ssmask(ji ,jj ) + ssmask(ji+1,jj ) ) ) + 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 ) + ! + ftne(1,:) = 0._wp ; ftnw(1,:) = 0._wp ; ftse(1,:) = 0._wp ; ftsw(1,:) = 0._wp + DO jj = 2, jpj + DO ji = 2, jpi + 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 = 2, jpj + DO ji = 2, jpi + z1_ht = ssmask(ji,jj) / ( ht_n(ji,jj) + 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 + ! + CASE( np_ENE, np_ENS , np_MIX ) != all other schemes (ENE, ENS, MIX) except ENT ! + ! + zwz(:,:) = 0._wp + zhf(:,:) = 0._wp + + !!gm assume 0 in both cases (which is almost surely WRONG ! ) as hvatf has been removed +!!gm A priori a better value should be something like : +!!gm zhf(i,j) = masked sum of ht(i,j) , ht(i+1,j) , ht(i,j+1) , (i+1,j+1) +!!gm divided by the sum of the corresponding mask +!!gm +!! + IF( .NOT.ln_sco ) THEN + + !!gm agree the JC comment : this should be done in a much clear way + + ! JC: It not clear yet what should be the depth at f-points over land in z-coordinate case + ! Set it to zero for the time being + ! IF( rn_hmin < 0._wp ) THEN ; jk = - INT( rn_hmin ) ! from a nb of level + ! ELSE ; jk = MINLOC( gdepw_0, mask = gdepw_0 > rn_hmin, dim = 1 ) ! from a depth + ! ENDIF + ! zhf(:,:) = gdepw_0(:,:,jk+1) + ! + ELSE + ! + !zhf(:,:) = hbatf(:,:) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zhf(ji,jj) = ( ht_0 (ji,jj ) + ht_0 (ji+1,jj ) & + & + ht_0 (ji,jj+1) + ht_0 (ji+1,jj+1) ) & + & / MAX( ssmask(ji,jj ) + ssmask(ji+1,jj ) & + & + ssmask(ji,jj+1) + ssmask(ji+1,jj+1) , 1._wp ) + END DO + END DO + ENDIF + ! + DO jj = 1, jpjm1 + zhf(:,jj) = zhf(:,jj) * (1._wp- umask(:,jj,1) * umask(:,jj+1,1)) + END DO + ! + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + zhf(:,jj) = zhf(:,jj) + e3f_n(:,jj,jk) * umask(:,jj,jk) * umask(:,jj+1,jk) + END DO + END DO + CALL lbc_lnk( 'dynspg_ts', zhf, 'F', 1._wp ) + ! JC: TBC. hf should be greater than 0 + DO jj = 1, jpj + DO ji = 1, jpi + IF( zhf(ji,jj) /= 0._wp ) zwz(ji,jj) = 1._wp / zhf(ji,jj) + END DO + END DO + zwz(:,:) = ff_f(:,:) * zwz(:,:) + END SELECT + + END SUBROUTINE dyn_cor_2d_init + + + + SUBROUTINE dyn_cor_2d( hu_n, hv_n, un_b, vn_b, 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 ) :: hu_n, hv_n, un_b, vn_b, zhU, zhV + 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 = 2, jpjm1 + DO ji = 2, jpim1 + z1_hu = ssumask(ji,jj) / ( hu_n(ji,jj) + 1._wp - ssumask(ji,jj) ) + z1_hv = ssvmask(ji,jj) / ( hv_n(ji,jj) + 1._wp - ssvmask(ji,jj) ) + zu_trd(ji,jj) = + r1_4 * r1_e1e2u(ji,jj) * z1_hu & + & * ( e1e2t(ji+1,jj)*ht_n(ji+1,jj)*ff_t(ji+1,jj) * ( vn_b(ji+1,jj) + vn_b(ji+1,jj-1) ) & + & + e1e2t(ji ,jj)*ht_n(ji ,jj)*ff_t(ji ,jj) * ( vn_b(ji ,jj) + vn_b(ji ,jj-1) ) ) + ! + zv_trd(ji,jj) = - r1_4 * r1_e1e2v(ji,jj) * z1_hv & + & * ( e1e2t(ji,jj+1)*ht_n(ji,jj+1)*ff_t(ji,jj+1) * ( un_b(ji,jj+1) + un_b(ji-1,jj+1) ) & + & + e1e2t(ji,jj )*ht_n(ji,jj )*ff_t(ji,jj ) * ( un_b(ji,jj ) + un_b(ji-1,jj ) ) ) + END DO + END DO + ! + CASE( np_ENE , np_MIX ) ! energy conserving scheme (t-point) ENE or MIX + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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) :: phU, phV, pu, pv ! 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 = 1, jpj + DO ji = 1, jpim1 ! 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 = 1, jpjm1 ! not jpj-row + DO ji = 1, jpi + 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( sshn, zcpx, zcpy ) + !!--------------------------------------------------------------------- + !! *** ROUTINE wad_sp *** + !! + !! ** Purpose : + !!---------------------------------------------------------------------- + INTEGER :: ji ,jj ! dummy loop indices + LOGICAL :: ll_tmp1, ll_tmp2 + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ) :: sshn + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: zcpx, zcpy + !!---------------------------------------------------------------------- + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ll_tmp1 = MIN( sshn(ji,jj) , sshn(ji+1,jj) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji+1,jj) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji+1,jj) + ht_0(ji+1,jj) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji+1,jj) - sshn(ji ,jj)) > 1.E-12 ).AND.( & + & MAX( sshn(ji,jj) , sshn(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 sshn(ji+1,jj) - sshn(ji ,jj) = 0, it won't happen ! here + zcpx(ji,jj) = ABS( (sshn(ji+1,jj) + ht_0(ji+1,jj) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji+1,jj) - sshn(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( sshn(ji,jj) , sshn(ji,jj+1) ) > & + & MAX( -ht_0(ji,jj) , -ht_0(ji,jj+1) ) .AND. & + & MAX( sshn(ji,jj) + ht_0(ji,jj) , sshn(ji,jj+1) + ht_0(ji,jj+1) ) & + & > rn_wdmin1 + rn_wdmin2 + ll_tmp2 = ( ABS( sshn(ji,jj) - sshn(ji,jj+1)) > 1.E-12 ).AND.( & + & MAX( sshn(ji,jj) , sshn(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 sshn(ji,jj+1) - sshn(ji,jj ) = 0, it won't happen ! here + zcpy(ji,jj) = ABS( (sshn(ji,jj+1) + ht_0(ji,jj+1) - sshn(ji,jj) - ht_0(ji,jj)) & + & / (sshn(ji,jj+1) - sshn(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( 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 + !!---------------------------------------------------------------------- + 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 = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + 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 = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + 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 = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + ikbu = mbku(ji,jj) + ikbv = mbkv(ji,jj) + zu_i(ji,jj) = un(ji,jj,ikbu) - un_b(ji,jj) + zv_i(ji,jj) = vn(ji,jj,ikbv) - vn_b(ji,jj) + END DO + END DO + ELSE ! CENTRED integration: use BEFORE bottom baroclinic velocities + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + ikbu = mbku(ji,jj) + ikbv = mbkv(ji,jj) + zu_i(ji,jj) = ub(ji,jj,ikbu) - ub_b(ji,jj) + zv_i(ji,jj) = vb(ji,jj,ikbv) - vb_b(ji,jj) + END DO + END DO + ENDIF + ! + IF( ln_wd_il ) THEN ! W/D : use the "clipped" bottom friction !!gm explain WHY, please ! + zztmp = -1._wp / rdtbt + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + zu_i(ji,jj) * wdrampu(ji,jj) * MAX( & + & r1_hu_n(ji,jj) * 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_n(ji,jj) * 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 = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * 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_n(ji,jj) * 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 = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + iktu = miku(ji,jj) + iktv = mikv(ji,jj) + zu_i(ji,jj) = un(ji,jj,iktu) - un_b(ji,jj) + zv_i(ji,jj) = vn(ji,jj,iktv) - vn_b(ji,jj) + END DO + END DO + ELSE ! CENTRED integration: use BEFORE top baroclinic velocity + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + iktu = miku(ji,jj) + iktv = mikv(ji,jj) + zu_i(ji,jj) = ub(ji,jj,iktu) - ub_b(ji,jj) + zv_i(ji,jj) = vb(ji,jj,iktv) - vb_b(ji,jj) + END DO + END DO + ENDIF + ! + ! ! use "unclipped" top drag (even if explicit friction is used in 3D calculation) + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! INNER domain + pu_RHSi(ji,jj) = pu_RHSi(ji,jj) + r1_hu_n(ji,jj) * 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_n(ji,jj) * 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, za1, za2, za3 ! 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/NEMO_4.0.4_surge/src/OCE/DYN/dynvor.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynvor.F90 new file mode 100644 index 0000000..b78cb92 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynvor.F90 @@ -0,0 +1,958 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! dyn_vor : Update the momentum trend with the vorticity trend + !! vor_ens : enstrophy conserving scheme (ln_dynvor_ens=T) + !! vor_ene : energy conserving scheme (ln_dynvor_ene=T) + !! vor_een : energy and enstrophy conserving (ln_dynvor_een=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 ! 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) + INTEGER, PUBLIC :: nn_een_e3f !: e3f=masked averaging of e3t divided by 4 (=0) or by the sum of mask (=1) + 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 :: 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) :: 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 "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_vor( kt ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !! + !! ** Action : - Update (ua,va) 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 + ! + REAL(wp), 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(:,:,:) = ua(:,:,:) !* planetary vorticity trend (including Stokes-Coriolis force) + ztrdv(:,:,:) = va(:,:,:) + SELECT CASE( nvor_scheme ) + CASE( np_ENS ) ; CALL vor_ens( kt, ncor, un , vn , ua, va ) ! enstrophy conserving scheme + IF( ln_stcor ) CALL vor_ens( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENE, np_MIX ) ; CALL vor_ene( kt, ncor, un , vn , ua, va ) ! energy conserving scheme + IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENT ) ; CALL vor_enT( kt, ncor, un , vn , ua, va ) ! energy conserving scheme (T-pts) + IF( ln_stcor ) CALL vor_enT( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EET ) ; CALL vor_eeT( kt, ncor, un , vn , ua, va ) ! energy conserving scheme (een with e3t) + IF( ln_stcor ) CALL vor_eeT( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EEN ) ; CALL vor_een( kt, ncor, un , vn , ua, va ) ! energy & enstrophy scheme + IF( ln_stcor ) CALL vor_een( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + END SELECT + ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_pvo, kt ) + ! + IF( n_dynadv /= np_LIN_dyn ) THEN !* relative vorticity or metric trend (only in non-linear case) + ztrdu(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + SELECT CASE( nvor_scheme ) + CASE( np_ENT ) ; CALL vor_enT( kt, nrvm, un , vn , ua, va ) ! energy conserving scheme (T-pts) + CASE( np_EET ) ; CALL vor_eeT( kt, nrvm, un , vn , ua, va ) ! energy conserving scheme (een with e3t) + CASE( np_ENE ) ; CALL vor_ene( kt, nrvm, un , vn , ua, va ) ! energy conserving scheme + CASE( np_ENS, np_MIX ) ; CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! enstrophy conserving scheme + CASE( np_EEN ) ; CALL vor_een( kt, nrvm, un , vn , ua, va ) ! energy & enstrophy scheme + END SELECT + ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_rvo, kt ) + 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, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_enT( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EET ) !* energy conserving scheme (een scheme using e3t) + CALL vor_eeT( kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_eeT( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENE ) !* energy conserving scheme + CALL vor_ene( kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_ENS ) !* enstrophy conserving scheme + CALL vor_ens( kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_ens( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_MIX ) !* mixed ene-ens scheme + CALL vor_ens( kt, nrvm, un , vn , ua, va ) ! relative vorticity or metric trend (ens) + CALL vor_ene( kt, ncor, un , vn , ua, va ) ! planetary vorticity trend (ene) + IF( ln_stcor ) CALL vor_ene( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + CASE( np_EEN ) !* energy and enstrophy conserving scheme + CALL vor_een( kt, ntot, un , vn , ua, va ) ! total vorticity trend + IF( ln_stcor ) CALL vor_een( kt, ncor, usd, vsd, ua, va ) ! add the Stokes-Coriolis trend + END SELECT + ! + ENDIF + ! + ! ! print sum trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' vor - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_vor') + ! + END SUBROUTINE dyn_vor + + + SUBROUTINE vor_enT( kt, 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 (ua,va) with the now vorticity term trend + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + INTEGER , INTENT(in ) :: kvor ! total, planetary, relative, or metric + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pu, pv ! now velocities + REAL(wp), 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(jpi,jpj) :: zwx, zwy, zwt ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz ! 3D workspace + !!---------------------------------------------------------------------- + ! + 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 + ! + ! + SELECT CASE( kvor ) !== volume weighted vorticity considered ==! + CASE ( np_RVO ) !* relative vorticity + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + 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/unmask relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + END DO + + CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) + + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jk = 1, jpkm1 ! Horizontal slab + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! relative vorticity + 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/unmask relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + END DO + + CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) + + END SELECT + + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + + SELECT CASE( kvor ) !== volume weighted vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + zwt(:,:) = ff_t(:,:) * e1e2t(:,:)*e3t_n(:,:,jk) + CASE ( np_RVO ) !* relative vorticity + DO jj = 2, jpj + DO ji = 2, jpi ! vector opt. + 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_n(ji,jj,jk) + END DO + END DO + CASE ( np_MET ) !* metric term + DO jj = 2, jpj + DO ji = 2, jpi + 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_n(ji,jj,jk) + END DO + END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = 2, jpj + DO ji = 2, jpi ! vector opt. + 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_n(ji,jj,jk) + END DO + END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = 2, jpj + DO ji = 2, jpi ! vector opt. + 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_n(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 = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + pu_rhs(ji,jj,jk) = pu_rhs(ji,jj,jk) + r1_4 * r1_e1e2u(ji,jj) / e3u_n(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_n(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 + ! ! =============== + END SUBROUTINE vor_enT + + + SUBROUTINE vor_ene( kt, kvor, pun, pvn, pua, pva ) + !!---------------------------------------------------------------------- + !! *** 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 vn) ] + !! vorv = 1/e2v mi-1[ (rvor+f)/e3f mj(e2u*e3u un) ] + !! where rvor is the relative vorticity + !! + !! ** Action : - Update (ua,va) 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 ) :: kvor ! total, planetary, relative, or metric + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zx1, zy1, zx2, zy2 ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz ! 2D workspace + !!---------------------------------------------------------------------- + ! + 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 + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + zwz(:,:) = ff_f(:,:) + CASE ( np_RVO ) !* relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO + END DO + CASE ( np_MET ) !* metric term + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO + END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO + END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(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 + ! + IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + + IF( ln_sco ) THEN + zwz(:,:) = zwz(:,:) / e3f_n(:,:,jk) + zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) + zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) + ELSE + zwx(:,:) = e2u(:,:) * pun(:,:,jk) + zwy(:,:) = e1v(:,:) * pvn(:,:,jk) + ENDIF + ! !== compute and add the vorticity term trend =! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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) + pua(ji,jj,jk) = pua(ji,jj,jk) + r1_4 * r1_e1u(ji,jj) * ( zwz(ji ,jj-1) * zy1 + zwz(ji,jj) * zy2 ) + pva(ji,jj,jk) = pva(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, kvor, pun, pvn, pua, pva ) + !!---------------------------------------------------------------------- + !! *** 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 vn) ] + !! vorv = 1/e2v mi-1[ (rvor+f)/e3f ] mi-1[ mj(e2u*e3u un) ] + !! Add this trend to the general momentum trend (ua,va): + !! (ua,va) = (ua,va) + ( voru , vorv ) + !! + !! ** Action : - Update (ua,va) 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 ) :: kvor ! total, planetary, relative, or metric + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! total v-trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zuav, zvau ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zwx, zwy, zwz, zww ! 2D workspace + !!---------------------------------------------------------------------- + ! + 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 + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + zwz(:,:) = ff_f(:,:) + CASE ( np_RVO ) !* relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO + END DO + CASE ( np_MET ) !* metric term + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO + END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ff_f(ji,jj) + ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) * r1_e1e2f(ji,jj) + END DO + END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = ff_f(ji,jj) + ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(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 + ! + IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj) = zwz(ji,jj) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + ! + IF( ln_sco ) THEN !== horizontal fluxes ==! + zwz(:,:) = zwz(:,:) / e3f_n(:,:,jk) + zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) + zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) + ELSE + zwx(:,:) = e2u(:,:) * pun(:,:,jk) + zwy(:,:) = e1v(:,:) * pvn(:,:,jk) + ENDIF + ! !== compute and add the vorticity term trend =! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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) ) + pua(ji,jj,jk) = pua(ji,jj,jk) + zuav * ( zwz(ji ,jj-1) + zwz(ji,jj) ) + pva(ji,jj,jk) = pva(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, kvor, pun, pvn, pua, pva ) + !!---------------------------------------------------------------------- + !! *** 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 (ua,va). + !! + !! ** Action : - Update (ua,va) 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 ) :: kvor ! total, planetary, relative, or metric + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! 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(jpi,jpj) :: zwx , zwy , z1_e3f + REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz + !!---------------------------------------------------------------------- + ! + 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 + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + SELECT CASE( nn_een_e3f ) ! == reciprocal of e3 at F-point + CASE ( 0 ) ! original formulation (masked averaging of e3t divided by 4) + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ze3f = ( e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & + & + e3t_n(ji,jj ,jk)*tmask(ji,jj ,jk) + e3t_n(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = 4._wp / ze3f + ELSE ; z1_e3f(ji,jj) = 0._wp + ENDIF + END DO + END DO + CASE ( 1 ) ! new formulation (masked averaging of e3t divided by the sum of mask) + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ze3f = ( e3t_n(ji,jj+1,jk)*tmask(ji,jj+1,jk) + e3t_n(ji+1,jj+1,jk)*tmask(ji+1,jj+1,jk) & + & + e3t_n(ji,jj ,jk)*tmask(ji,jj ,jk) + e3t_n(ji+1,jj ,jk)*tmask(ji+1,jj ,jk) ) + zmsk = ( tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk) & + & + tmask(ji,jj ,jk) + tmask(ji+1,jj ,jk) ) + IF( ze3f /= 0._wp ) THEN ; z1_e3f(ji,jj) = zmsk / ze3f + ELSE ; z1_e3f(ji,jj) = 0._wp + ENDIF + END DO + END DO + END SELECT + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ff_f(ji,jj) * z1_e3f(ji,jj) + END DO + END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( e2v(ji+1,jj ) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) * r1_e1e2f(ji,jj)*z1_e3f(ji,jj) + END DO + END DO + CASE ( np_MET ) !* metric term + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( ( pvn(ji+1,jj,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END DO + END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( e2v(ji+1,jj ) * pvn(ji+1,jj,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) & + & * r1_e1e2f(ji,jj) ) * z1_e3f(ji,jj) + END DO + END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(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 + ! + IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + END DO ! End of slab + ! + CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) + + DO jk = 1, jpkm1 ! Horizontal slab + ! + ! !== horizontal fluxes ==! + zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) + zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) + + ! !== compute and add the vorticity term trend =! + jj = 2 + ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0 + DO ji = 2, jpi ! split in 2 parts due to vector opt. + 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 + DO jj = 3, jpj + DO ji = fs_2, jpi ! vector opt. ok because we start at jj = 3 + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ) ) + pua(ji,jj,jk) = pua(ji,jj,jk) + zua + pva(ji,jj,jk) = pva(ji,jj,jk) + zva + END DO + END DO + ! ! =============== + END DO ! End of slab + ! ! =============== + END SUBROUTINE vor_een + + + + SUBROUTINE vor_eeT( kt, kvor, pun, pvn, pua, pva ) + !!---------------------------------------------------------------------- + !! *** 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 (ua,va). + !! + !! ** Action : - Update (ua,va) 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 ) :: kvor ! total, planetary, relative, or metric + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun, pvn ! now velocities + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pua, pva ! 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(jpi,jpj) :: zwx , zwy + REAL(wp), DIMENSION(jpi,jpj) :: ztnw, ztne, ztsw, ztse + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwz + !!---------------------------------------------------------------------- + ! + 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 + ! + ! ! =============== + DO jk = 1, jpkm1 ! Horizontal slab + ! ! =============== + ! + ! + SELECT CASE( kvor ) !== vorticity considered ==! + CASE ( np_COR ) !* Coriolis (planetary vorticity) + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ff_f(ji,jj) + END DO + END DO + CASE ( np_RVO ) !* relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) & + & * r1_e1e2f(ji,jj) + END DO + END DO + CASE ( np_MET ) !* metric term + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(ji,jj,jk) ) * dj_e1u_2e1e2f(ji,jj) + END DO + END DO + CASE ( np_CRV ) !* Coriolis + relative vorticity + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ( ff_f(ji,jj) + ( e2v(ji+1,jj ) * pvn(ji+1,jj ,jk) - e2v(ji,jj) * pvn(ji,jj,jk) & + & - e1u(ji ,jj+1) * pun(ji ,jj+1,jk) + e1u(ji,jj) * pun(ji,jj,jk) ) & + & * r1_e1e2f(ji,jj) ) + END DO + END DO + CASE ( np_CME ) !* Coriolis + metric + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = ff_f(ji,jj) + ( pvn(ji+1,jj ,jk) + pvn(ji,jj,jk) ) * di_e2v_2e1e2f(ji,jj) & + & - ( pun(ji ,jj+1,jk) + pun(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 + ! + IF( ln_dynvor_msk ) THEN !== mask/unmask vorticity ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = zwz(ji,jj,jk) * fmask(ji,jj,jk) + END DO + END DO + ENDIF + END DO + ! + CALL lbc_lnk( 'dynvor', zwz, 'F', 1. ) + ! + DO jk = 1, jpkm1 ! Horizontal slab + + ! !== horizontal fluxes ==! + zwx(:,:) = e2u(:,:) * e3u_n(:,:,jk) * pun(:,:,jk) + zwy(:,:) = e1v(:,:) * e3v_n(:,:,jk) * pvn(:,:,jk) + + ! !== compute and add the vorticity term trend =! + jj = 2 + ztne(1,:) = 0 ; ztnw(1,:) = 0 ; ztse(1,:) = 0 ; ztsw(1,:) = 0 + DO ji = 2, jpi ! split in 2 parts due to vector opt. + z1_e3t = 1._wp / e3t_n(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 + DO jj = 3, jpj + DO ji = fs_2, jpi ! vector opt. ok because we start at jj = 3 + z1_e3t = 1._wp / e3t_n(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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ) ) + pua(ji,jj,jk) = pua(ji,jj,jk) + zua + pva(ji,jj,jk) = pva(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 + !! + NAMELIST/namdyn_vor/ ln_dynvor_ens, ln_dynvor_ene, ln_dynvor_enT, ln_dynvor_eeT, & + & ln_dynvor_een, nn_een_e3f , 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 + ! + REWIND( numnam_ref ) ! Namelist namdyn_vor in reference namelist : Vorticity scheme options + READ ( numnam_ref, namdyn_vor, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_vor in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namdyn_vor in configuration namelist : Vorticity scheme options + 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_een_e3f = ', nn_een_e3f + 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 + + IF( ln_dynvor_msk ) CALL ctl_stop( 'dyn_vor_init: masked vorticity is not currently not available') + +!!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 = 1, jpjm1 + DO ji = 1, jpim1 + 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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_multi( 'dynvor', di_e2u_2, 'T', -1. , dj_e1v_2, 'T', -1. ) ! 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 = 1, jpjm1 + DO ji = 1, jpim1 + 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_multi( 'dynvor', di_e2v_2e1e2f, 'F', -1. , dj_e1u_2e1e2f, 'F', -1. ) ! Lateral boundary conditions + END SELECT + ! + 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)' + 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/NEMO_4.0.4_surge/src/OCE/DYN/dynzad.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynzad.F90 new file mode 100644 index 0000000..243539e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynzad.F90 @@ -0,0 +1,124 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_zad ( kt ) + !!---------------------------------------------------------------------- + !! *** 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) = ua + 1/(e1e2u*e3u) mk+1[ mi(e1e2t*wn) dk(un) ] + !! w dz(v) = va + 1/(e1e2v*e3v) mk+1[ mj(e1e2t*wn) dk(vn) ] + !! Add this trend to the general trend (ua,va): + !! (ua,va) = (ua,va) + w dz(u,v) + !! + !! ** Action : - Update (ua,va) 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 :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zua, zva ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zww + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwuw, zwvw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_zad') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'dyn_zad : 2nd order vertical advection scheme' + ENDIF + + IF( l_trddyn ) THEN ! Save ua and va trends + ALLOCATE( ztrdu(jpi,jpj,jpk) , ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + ENDIF + + DO jk = 2, jpkm1 ! Vertical momentum advection at level w and u- and v- vertical + DO jj = 2, jpj ! vertical fluxes + DO ji = fs_2, jpi ! vector opt. + zww(ji,jj) = 0.25_wp * e1e2t(ji,jj) * wn(ji,jj,jk) + END DO + END DO + DO jj = 2, jpjm1 ! vertical momentum advection at w-point + DO ji = fs_2, fs_jpim1 ! vector opt. + zwuw(ji,jj,jk) = ( zww(ji+1,jj ) + zww(ji,jj) ) * ( un(ji,jj,jk-1) - un(ji,jj,jk) ) + zwvw(ji,jj,jk) = ( zww(ji ,jj+1) + zww(ji,jj) ) * ( vn(ji,jj,jk-1) - vn(ji,jj,jk) ) + END DO + END DO + END DO + ! + ! Surface and bottom advective fluxes set to zero + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! Vertical momentum advection at u- and v-points + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jk) = ua(ji,jj,jk) - ( zwuw(ji,jj,jk) + zwuw(ji,jj,jk+1) ) * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) - ( zwvw(ji,jj,jk) + zwvw(ji,jj,jk+1) ) * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) + END DO + END DO + END DO + + IF( l_trddyn ) THEN ! save the vertical advection trends for diagnostic + ztrdu(:,:,:) = ua(:,:,:) - ztrdu(:,:,:) + ztrdv(:,:,:) = va(:,:,:) - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zad, kt ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! Control print + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' zad - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_zad') + ! + END SUBROUTINE dyn_zad + + !!====================================================================== +END MODULE dynzad diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/dynzdf.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/dynzdf.F90 new file mode 100644 index 0000000..ef71fea --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/dynzdf.F90 @@ -0,0 +1,502 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dyn_zdf( kt ) + !!---------------------------------------------------------------------- + !! *** 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 + !! ua = ub + 2*dt * ua vector form or linear free surf. + !! ua = ( e3u_b*ub + 2*dt * e3u_n*ua ) / e3u_a otherwise + !! - update the after velocity with the implicit vertical mixing. + !! This requires to solver the following system: + !! ua = ua + 1/e3u_a dk+1[ mi(avm) / e3uw_a 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 : (ua,va) after velocity + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + 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(jpi,jpj,jpk) :: zwi, zwd, zws ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv ! - - + !!--------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('dyn_zdf') + ! + 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 + ! !* set time step + IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! = rdt (restart with Euler time stepping) + ELSEIF( kt <= nit000 + 1 ) THEN ; r2dt = 2. * rdt ! = 2 rdt (leapfrog) + ENDIF + ! + ! !* explicit top/bottom drag case + IF( .NOT.ln_drgimp ) CALL zdf_drg_exp( kt, ub, vb, ua, va ) ! add top/bottom friction trend to (ua,va) + ! + ! + IF( l_trddyn ) THEN !* temporary save of ta and sa trends + ALLOCATE( ztrdu(jpi,jpj,jpk), ztrdv(jpi,jpj,jpk) ) + ztrdu(:,:,:) = ua(:,:,:) + ztrdv(:,:,:) = va(:,:,:) + ENDIF + ! + ! !== RHS: Leap-Frog time stepping on all trends but the vertical mixing ==! (put in ua,va) + ! + ! ! time stepping except vertical diffusion + IF( ln_dynadv_vec .OR. ln_linssh ) THEN ! applied on velocity + DO jk = 1, jpkm1 + ua(:,:,jk) = ( ub(:,:,jk) + r2dt * ua(:,:,jk) ) * umask(:,:,jk) + va(:,:,jk) = ( vb(:,:,jk) + r2dt * va(:,:,jk) ) * vmask(:,:,jk) + END DO + ELSE ! applied on thickness weighted velocity + DO jk = 1, jpkm1 + ua(:,:,jk) = ( e3u_b(:,:,jk) * ub(:,:,jk) & + & + r2dt * e3u_n(:,:,jk) * ua(:,:,jk) ) / e3u_a(:,:,jk) * umask(:,:,jk) + va(:,:,jk) = ( e3v_b(:,:,jk) * vb(:,:,jk) & + & + r2dt * e3v_n(:,:,jk) * va(:,:,jk) ) / e3v_a(:,:,jk) * vmask(:,:,jk) + 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_a = e3u_n = e3u_0, so systematic use of e3u_a + IF( ln_drgimp .AND. ln_dynspg_ts ) THEN + DO jk = 1, jpkm1 ! remove barotropic velocities + ua(:,:,jk) = ( ua(:,:,jk) - ua_b(:,:) ) * umask(:,:,jk) + va(:,:,jk) = ( va(:,:,jk) - va_b(:,:) ) * vmask(:,:,jk) + END DO + DO jj = 2, jpjm1 ! Add bottom/top stress due to barotropic component only + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) + ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_bot(ji+1,jj)+rCdU_bot(ji,jj) ) * ua_b(ji,jj) / ze3ua + va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * va_b(ji,jj) / ze3va + END DO + END DO + IF( ln_isfcav.OR.ln_drgice_imp ) THEN ! Ocean cavities (ISF) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) + ua(ji,jj,iku) = ua(ji,jj,iku) + r2dt * 0.5*( rCdU_top(ji+1,jj)+rCdU_top(ji,jj) ) * ua_b(ji,jj) / ze3ua + va(ji,jj,ikv) = va(ji,jj,ikv) + r2dt * 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) * va_b(ji,jj) / ze3va + END DO + END DO + END IF + ENDIF + ! + ! !== Vertical diffusion on u ==! + ! + ! !* Matrix construction + zdt = r2dt * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(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_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & + & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 !* Surface boundary conditions + DO ji = fs_2, fs_jpim1 ! vector opt. + zwi(ji,jj,1) = 0._wp + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) + zzws = - zdt * ( avm(ji+1,jj,2) + avm(ji ,jj,2) ) / ( ze3ua * e3uw_n(ji,jj,2) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(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_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) + akzu(ji,jj,jk+1) ) & + & / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,jk) + r_vvl * e3u_a(ji,jj,jk) ! after scale factor at U-point + zzwi = - zdt * ( avm(ji+1,jj,jk ) + avm(ji,jj,jk ) ) / ( ze3ua * e3uw_n(ji,jj,jk ) ) * wumask(ji,jj,jk ) + zzws = - zdt * ( avm(ji+1,jj,jk+1) + avm(ji,jj,jk+1) ) / ( ze3ua * e3uw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 !* Surface boundary conditions + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = 2, jpim1 + iku = mbku(ji,jj) ! ocean bottom level at u- and v-points + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) ! after scale factor at T-point + zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 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 = 2, jpjm1 + DO ji = 2, jpim1 + !!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_n(ji,jj,iku) + r_vvl * e3u_a(ji,jj,iku) ! after scale factor at T-point + zwd(ji,jj,iku) = zwd(ji,jj,iku) - r2dt * 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 ua + !----------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3ua = ( 1._wp - r_vvl ) * e3u_n(ji,jj,1) + r_vvl * e3u_a(ji,jj,1) + ua(ji,jj,1) = ua(ji,jj,1) + r2dt * 0.5_wp * ( utau_b(ji,jj) + utau(ji,jj) ) & + & / ( ze3ua * rau0 ) * umask(ji,jj,1) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ua(ji,jj,jk) = ua(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * ua(ji,jj,jk-1) + END DO + END DO + END DO + ! + DO jj = 2, jpjm1 !== thrid recurrence : SOLk = ( Lk - Uk * Ek+1 ) / Dk ==! + DO ji = fs_2, fs_jpim1 ! vector opt. + ua(ji,jj,jpkm1) = ua(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) + END DO + END DO + DO jk = jpk-2, 1, -1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ua(ji,jj,jk) = ( ua(ji,jj,jk) - zws(ji,jj,jk) * ua(ji,jj,jk+1) ) / zwd(ji,jj,jk) + END DO + END DO + END DO + ! + ! !== Vertical diffusion on v ==! + ! + ! !* Matrix construction + zdt = r2dt * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(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_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & + & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 !* Surface boundary conditions + DO ji = fs_2, fs_jpim1 ! vector opt. + zwi(ji,jj,1) = 0._wp + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) + zzws = - zdt * ( avm(ji,jj+1,2) + avm(ji,jj,2) ) / ( ze3va * e3vw_n(ji,jj,2) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(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_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) + akzv(ji,jj,jk+1) ) & + & / ( ze3va * e3vw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,jk) + r_vvl * e3v_a(ji,jj,jk) ! after scale factor at V-point + zzwi = - zdt * ( avm(ji,jj+1,jk ) + avm(ji,jj,jk ) ) / ( ze3va * e3vw_n(ji,jj,jk ) ) * wvmask(ji,jj,jk ) + zzws = - zdt * ( avm(ji,jj+1,jk+1) + avm(ji,jj,jk+1) ) / ( ze3va * e3vw_n(ji,jj,jk+1) ) * 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 = 2, jpjm1 !* Surface boundary conditions + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = 2, jpim1 + ikv = mbkv(ji,jj) ! (deepest ocean u- and v-points) + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) ! after scale factor at T-point + zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 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 = 2, jpjm1 + DO ji = 2, jpim1 + ikv = mikv(ji,jj) ! (first wet ocean u- and v-points) + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,ikv) + r_vvl * e3v_a(ji,jj,ikv) ! after scale factor at T-point + zwd(ji,jj,ikv) = zwd(ji,jj,ikv) - r2dt * 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 !== First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 (increasing k) == + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 !== second recurrence: SOLk = RHSk - Lk / Dk-1 Lk-1 ==! + DO ji = fs_2, fs_jpim1 ! vector opt. + ze3va = ( 1._wp - r_vvl ) * e3v_n(ji,jj,1) + r_vvl * e3v_a(ji,jj,1) + va(ji,jj,1) = va(ji,jj,1) + r2dt * 0.5_wp * ( vtau_b(ji,jj) + vtau(ji,jj) ) & + & / ( ze3va * rau0 ) * vmask(ji,jj,1) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + va(ji,jj,jk) = va(ji,jj,jk) - zwi(ji,jj,jk) / zwd(ji,jj,jk-1) * va(ji,jj,jk-1) + END DO + END DO + END DO + ! + DO jj = 2, jpjm1 !== third recurrence : SOLk = ( Lk - Uk * SOLk+1 ) / Dk ==! + DO ji = fs_2, fs_jpim1 ! vector opt. + va(ji,jj,jpkm1) = va(ji,jj,jpkm1) / zwd(ji,jj,jpkm1) + END DO + END DO + DO jk = jpk-2, 1, -1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + va(ji,jj,jk) = ( va(ji,jj,jk) - zws(ji,jj,jk) * va(ji,jj,jk+1) ) / zwd(ji,jj,jk) + END DO + END DO + END DO + ! + IF( l_trddyn ) THEN ! save the vertical diffusive trends for further diagnostics + ztrdu(:,:,:) = ( ua(:,:,:) - ub(:,:,:) ) / r2dt - ztrdu(:,:,:) + ztrdv(:,:,:) = ( va(:,:,:) - vb(:,:,:) ) / r2dt - ztrdv(:,:,:) + CALL trd_dyn( ztrdu, ztrdv, jpdyn_zdf, kt ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=ua, clinfo1=' zdf - Ua: ', mask1=umask, & + & tab3d_2=va, clinfo2= ' Va: ', mask2=vmask, clinfo3='dyn' ) + ! + IF( ln_timing ) CALL timing_stop('dyn_zdf') + ! + END SUBROUTINE dyn_zdf + + !!============================================================================== +END MODULE dynzdf diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/sshwzv.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/sshwzv.F90 new file mode 100644 index 0000000..7c24f6b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/sshwzv.F90 @@ -0,0 +1,389 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! ssh_nxt : after ssh + !! ssh_swp : filter ans swap the ssh arrays + !! wzv : compute now vertical velocity + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + 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 +#if defined key_agrif + USE agrif_oce_interp +#endif + ! + 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 + USE wet_dry ! Wetting/Drying flux limiting + + IMPLICIT NONE + PRIVATE + + PUBLIC ssh_nxt ! called by step.F90 + PUBLIC wzv ! called by step.F90 + PUBLIC wAimp ! called by step.F90 + PUBLIC ssh_swp ! called by step.F90 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ssh_nxt( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_nxt *** + !! + !! ** Purpose : compute the after ssh (ssha) + !! + !! ** Method : - Using the incompressibility hypothesis, the ssh increment + !! is computed by integrating the horizontal divergence and multiply by + !! by the time step. + !! + !! ** action : ssha, after sea surface height + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + ! + INTEGER :: jk ! dummy loop indice + REAL(wp) :: z2dt, zcoef ! local scalars + 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 + ! + z2dt = 2._wp * rdt ! set time step size (Euler/Leapfrog) + IF( neuler == 0 .AND. kt == nit000 ) z2dt = rdt + zcoef = 0.5_wp * r1_rau0 + + ! !------------------------------! + ! ! After Sea Surface Height ! + ! !------------------------------! + IF(ln_wd_il) THEN + CALL wad_lmt(sshb, zcoef * (emp_b(:,:) + emp(:,:)), z2dt) + ENDIF + + CALL div_hor( kt ) ! Horizontal divergence + ! + zhdiv(:,:) = 0._wp + DO jk = 1, jpkm1 ! Horizontal divergence of barotropic transports + zhdiv(:,:) = zhdiv(:,:) + e3t_n(:,:,jk) * hdivn(:,:,jk) + 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. + ! + ssha(:,:) = ( sshb(:,:) - z2dt * ( zcoef * ( emp_b(:,:) + emp(:,:) ) + zhdiv(:,:) ) ) * ssmask(:,:) + ! +#if defined key_agrif + CALL agrif_ssh( kt ) +#endif + ! + IF ( .NOT.ln_dynspg_ts ) THEN + IF( ln_bdy ) THEN + CALL lbc_lnk( 'sshwzv', ssha, 'T', 1. ) ! Not sure that's necessary + CALL bdy_ssh( ssha ) ! Duplicate sea level across open boundaries + ENDIF + ENDIF + ! !------------------------------! + ! ! outputs ! + ! !------------------------------! + ! + IF(ln_ctl) CALL prt_ctl( tab2d_1=ssha, clinfo1=' ssha - : ', mask1=tmask ) + ! + IF( ln_timing ) CALL timing_stop('ssh_nxt') + ! + END SUBROUTINE ssh_nxt + + + SUBROUTINE wzv( kt ) + !!---------------------------------------------------------------------- + !! *** 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 : wn : now vertical velocity + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! time step + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: z1_2dt ! local scalars + 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,*) '~~~~~ ' + ! + wn(:,:,jpk) = 0._wp ! bottom boundary condition: w=0 (set once for all) + ENDIF + ! !------------------------------! + ! ! Now Vertical Velocity ! + ! !------------------------------! + z1_2dt = 1. / ( 2. * rdt ) ! set time step size (Euler/Leapfrog) + IF( neuler == 0 .AND. kt == nit000 ) z1_2dt = 1. / rdt + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + CALL lbc_lnk('sshwzv', zhdiv, 'T', 1.) ! - 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 hdivn. Perhaps just for security + DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence + ! computation of w + wn(:,:,jk) = wn(:,:,jk+1) - ( e3t_n(:,:,jk) * hdivn(:,:,jk) + zhdiv(:,:,jk) & + & + z1_2dt * ( e3t_a(:,:,jk) - e3t_b(:,:,jk) ) ) * tmask(:,:,jk) + END DO + ! IF( ln_vvl_layer ) wn(:,:,:) = 0.e0 + DEALLOCATE( zhdiv ) + ELSE ! z_star and linear free surface cases + DO jk = jpkm1, 1, -1 ! integrate from the bottom the hor. divergence + ! computation of w + wn(:,:,jk) = wn(:,:,jk+1) - ( e3t_n(:,:,jk) * hdivn(:,:,jk) & + & + z1_2dt * ( e3t_a(:,:,jk) - e3t_b(:,:,jk) ) ) * tmask(:,:,jk) + END DO + ENDIF + + IF( ln_bdy ) THEN + DO jk = 1, jpkm1 + wn(:,:,jk) = wn(:,:,jk) * bdytmask(:,:) + END DO + ENDIF + ! +#if defined key_agrif + IF( .NOT. AGRIF_Root() ) THEN + IF ( l_Eastedge ) wn(nlci-1 , : ,:) = 0.e0 ! east + IF ( l_Westedge ) wn(2 , : ,:) = 0.e0 ! west + IF ( l_Northedge ) wn(: ,nlcj-1 ,:) = 0.e0 ! north + IF ( l_Southedge ) wn(: ,2 ,:) = 0.e0 ! south + ENDIF +#endif + ! + IF( ln_timing ) CALL timing_stop('wzv') + ! + END SUBROUTINE wzv + + + SUBROUTINE ssh_swp( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ssh_nxt *** + !! + !! ** Purpose : achieve the sea surface height time stepping by + !! applying Asselin time filter and swapping the arrays + !! ssha already computed in ssh_nxt + !! + !! ** Method : - apply Asselin time fiter to now ssh (excluding the forcing + !! from the filter, see Leclair and Madec 2010) and swap : + !! sshn = ssha + atfp * ( sshb -2 sshn + ssha ) + !! - atfp * rdt * ( emp_b - emp ) / rau0 + !! sshn = ssha + !! + !! ** action : - sshb, sshn : before & now sea surface height + !! ready for the next time step + !! + !! Reference : Leclair, M., and G. Madec, 2009, Ocean Modelling. + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + REAL(wp) :: zcoef ! local scalar + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('ssh_swp') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'ssh_swp : Asselin time filter and swap of sea surface height' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! !== Euler time-stepping: no filter, just swap ==! + IF ( neuler == 0 .AND. kt == nit000 ) THEN + sshn(:,:) = ssha(:,:) ! now <-- after (before already = now) + ! + ELSE !== Leap-Frog time-stepping: Asselin filter + swap ==! + ! ! before <-- now filtered + sshb(:,:) = sshn(:,:) + atfp * ( sshb(:,:) - 2 * sshn(:,:) + ssha(:,:) ) + IF( .NOT.ln_linssh ) THEN ! before <-- with forcing removed + zcoef = atfp * rdt * r1_rau0 + sshb(:,:) = sshb(:,:) - zcoef * ( emp_b(:,:) - emp (:,:) & + & - rnf_b(:,:) + rnf (:,:) & + & + fwfisf_b(:,:) - fwfisf(:,:) ) * ssmask(:,:) + ENDIF + sshn(:,:) = ssha(:,:) ! now <-- after + ENDIF + ! + IF(ln_ctl) CALL prt_ctl( tab2d_1=sshb, clinfo1=' sshb - : ', mask1=tmask ) + ! + IF( ln_timing ) CALL timing_stop('ssh_swp') + ! + END SUBROUTINE ssh_swp + + SUBROUTINE wAimp( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wAimp *** + !! + !! ** Purpose : compute the Courant number and partition vertical velocity + !! if a proportion needs to be treated implicitly + !! + !! ** Method : - + !! + !! ** action : wn : 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 :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zCu, zcff, z1_e3t ! 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,*) '~~~~~ ' + wi(:,:,:) = 0._wp + ENDIF + ! + ! Calculate Courant numbers + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, fs_jpim1 ! vector opt. + z1_e3t = 1._wp / e3t_n(ji,jj,jk) + ! 2*rdt and not r2dt (for restartability) + Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & + & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk) + un_td(ji ,jj,jk), 0._wp ) - & + & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk) + un_td(ji-1,jj,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk) + vn_td(ji,jj ,jk), 0._wp ) - & + & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk) + 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 = 2, jpjm1 + DO ji = 2, fs_jpim1 ! vector opt. + z1_e3t = 1._wp / e3t_n(ji,jj,jk) + ! 2*rdt and not r2dt (for restartability) + Cu_adv(ji,jj,jk) = 2._wp * rdt * ( ( MAX( wn(ji,jj,jk) , 0._wp ) - MIN( wn(ji,jj,jk+1) , 0._wp ) ) & + & + ( MAX( e2u(ji ,jj)*e3u_n(ji ,jj,jk)*un(ji ,jj,jk), 0._wp ) - & + & MIN( e2u(ji-1,jj)*e3u_n(ji-1,jj,jk)*un(ji-1,jj,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & + ( MAX( e1v(ji,jj )*e3v_n(ji,jj ,jk)*vn(ji,jj ,jk), 0._wp ) - & + & MIN( e1v(ji,jj-1)*e3v_n(ji,jj-1,jk)*vn(ji,jj-1,jk), 0._wp ) ) & + & * r1_e1e2t(ji,jj) & + & ) * z1_e3t + END DO + END DO + END DO + ENDIF + CALL lbc_lnk( 'sshwzv', Cu_adv, 'T', 1. ) + ! + CALL iom_put("Courant",Cu_adv) + ! + IF( MAXVAL( Cu_adv(:,:,:) ) > Cu_min ) THEN ! Quick check if any breaches anywhere + DO jk = jpkm1, 2, -1 ! or scan Courant criterion and partition + DO jj = 1, jpj ! w where necessary + DO ji = 1, jpi + ! + zCu = MAX( Cu_adv(ji,jj,jk) , Cu_adv(ji,jj,jk-1) ) +! alt: +! IF ( wn(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 * wn(ji,jj,jk) + wn(ji,jj,jk) = ( 1._wp - zcff ) * wn(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",wn) + ! + IF( ln_timing ) CALL timing_stop('wAimp') + ! + END SUBROUTINE wAimp + !!====================================================================== +END MODULE sshwzv diff --git a/NEMO_4.0.4_surge/src/OCE/DYN/wet_dry.F90 b/NEMO_4.0.4_surge/src/OCE/DYN/wet_dry.F90 new file mode 100644 index 0000000..0206a89 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/DYN/wet_dry.F90 @@ -0,0 +1,401 @@ +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 + + !!---------------------------------------------------------------------- + !! 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 !: Wetting/drying activation switch if either ln_wd_il or ln_wd_dl + + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- +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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namwad in reference namelist : Parameters for Wetting/Drying + READ ( numnam_ref, namwad, IOSTAT = ios, ERR = 905) +905 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namwad in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namwad in configuration namelist : Parameters for Wetting/Drying + 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 + ll_wd = .FALSE. + 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 + ! + END SUBROUTINE wad_init + + + SUBROUTINE wad_lmt( sshb1, sshemp, z2dt ) + !!---------------------------------------------------------------------- + !! *** 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(wp), DIMENSION(:,:), INTENT(inout) :: sshb1 !!gm DOCTOR names: should start with p ! + REAL(wp), DIMENSION(:,:), INTENT(in ) :: sshemp + REAL(wp) , INTENT(in ) :: z2dt + ! + 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 + un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:) + vn(:,:,jk) = vn(:,:,jk) * 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_n(:,:,jk) * un(:,:,jk) * umask(:,:,jk) + zflxv(:,:) = zflxv(:,:) + e3v_n(:,:,jk) * vn(:,:,jk) * vmask(:,:,jk) + END DO + zflxu(:,:) = zflxu(:,:) * e2u(:,:) + zflxv(:,:) = zflxv(:,:) * e1v(:,:) + ! + wdmask(:,:) = 1._wp + DO jj = 2, jpj + DO ji = 2, jpi + ! + 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) + sshb1(ji,jj) - rn_wdmin1 + IF( zdep2 <= 0._wp ) THEN ! add more safty, but not necessary + sshb1(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(:,:) + sshb1(:,:) - rn_wdmin1)/(rn_wdmin0 - rn_wdmin1),1.0_wp) + !jth assume don't need a lbc_lnk here + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + 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 = 2, jpj + DO ji = 2, jpi + 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) + sshb1(ji,jj) - rn_wdmin1 - z2dt * sshemp(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_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. ) + ! + CALL mpp_max('wet_dry', jflag) !max over the global domain + ! + IF( jflag == 0 ) EXIT + ! + END DO ! jk1 loop + ! + DO jk = 1, jpkm1 + un(:,:,jk) = un(:,:,jk) * zwdlmtu(:,:) + vn(:,:,jk) = vn(:,:,jk) * zwdlmtv(:,:) + END DO + un_b(:,:) = un_b(:,:) * zwdlmtu(:, :) + vn_b(:,:) = vn_b(:,:) * zwdlmtv(:, :) + ! +!!gm TO BE SUPPRESSED ? these lbc_lnk are useless since zwdlmtu and zwdlmtv are defined everywhere ! + CALL lbc_lnk_multi( 'wet_dry', un , 'U', -1., vn , 'V', -1. ) + CALL lbc_lnk_multi( 'wet_dry', un_b, 'U', -1., vn_b, 'V', -1. ) +!!gm + ! + IF(jflag == 1 .AND. lwp) WRITE(numout,*) 'Need more iterations in wad_lmt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) + ! + IF( ln_timing ) CALL timing_stop('wad_lmt') ! + ! + END SUBROUTINE wad_lmt + + + SUBROUTINE wad_lmt_bt( zflxu, zflxv, sshn_e, zssh_frc, rdtbt ) + !!---------------------------------------------------------------------- + !! *** 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(wp) , INTENT(in ) :: rdtbt ! ocean time-step index + REAL(wp), DIMENSION(:,:), INTENT(inout) :: zflxu, zflxv, 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 = rdtbt + ! + zflxp(:,:) = 0._wp + zflxn(:,:) = 0._wp + zwdlmtu(:,:) = 1._wp + zwdlmtv(:,:) = 1._wp + ! + DO jj = 2, jpj ! Horizontal Flux in u and v direction + DO ji = 2, jpi + ! + 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 = 2, jpj + DO ji = 2, jpi + ! + 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 ! ji loop + END DO ! jj loop + ! + CALL lbc_lnk_multi( 'wet_dry', zwdlmtu, 'U', 1., zwdlmtv, 'V', 1. ) + ! + 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_multi( 'wet_dry', zflxu, 'U', -1., zflxv, 'V', -1. ) +!!gm end + ! + IF( jflag == 1 .AND. lwp ) WRITE(numout,*) 'Need more iterations in wad_lmt_bt!!!' + ! + !IF( ln_rnf ) CALL sbc_rnf_div( hdivn ) ! runoffs (update hdivn field) + ! + IF( ln_timing ) CALL timing_stop('wad_lmt_bt') ! + ! + END SUBROUTINE wad_lmt_bt + + !!============================================================================== +END MODULE wet_dry diff --git a/NEMO_4.0.4_surge/src/OCE/FLO/flo4rk.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/flo4rk.F90 new file mode 100644 index 0000000..b946c99 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/flo4rk.F90 @@ -0,0 +1,446 @@ +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 /) ! + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_4rk( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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( zgifl, zgjfl, zgkfl, zufl, zvfl, zwfl, jind ) + + ! computation of Runge-Kutta factor + DO jfl = 1, jpnfl + zrkxfl(jfl,jind) = rdt*zufl(jfl) + zrkyfl(jfl,jind) = rdt*zvfl(jfl) + zrkzfl(jfl,jind) = rdt*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( 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. + !!---------------------------------------------------------------------- + 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) * ub(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3)) + & + & tcoef2(ki) * un(iidu(jfl,jind1),ijdu(jfl,jind2),ikdu(jfl,jind3)) ) & + & / 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) * vb(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3)) + & + & tcoef2(ki) * vn(iidv(jfl,jind1),ijdv(jfl,jind2),ikdv(jfl,jind3)) ) & + & / 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) * wn(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3)) ) & + & / e3w_n(iidw(jfl,jind1),ijdw(jfl,jind2),ikdw(jfl,jind3)) + 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/NEMO_4.0.4_surge/src/OCE/FLO/flo_oce.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/flo_oce.F90 new file mode 100644 index 0000000..7960d20 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/flo_oce.F90 @@ -0,0 +1,66 @@ +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 !: 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$ + !! 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/NEMO_4.0.4_surge/src/OCE/FLO/floats.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/floats.F90 new file mode 100644 index 0000000..e453482 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/floats.F90 @@ -0,0 +1,141 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_stp( kt ) + !!---------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('flo_stp') + ! + IF( ln_flork4 ) THEN ; CALL flo_4rk( kt ) ! Trajectories using a 4th order Runge Kutta scheme + ELSE ; CALL flo_blk( kt ) ! Trajectories using Blanke' algorithme + ENDIF + ! + IF( lk_mpp ) CALL mppsync ! synchronization of all the processor + ! + CALL flo_wri( kt ) ! trajectories ouput + ! + CALL flo_rst( kt ) ! trajectories restart + ! + wb(:,:,:) = wn(:,:,:) ! Save the old vertical velocity field + ! + IF( ln_timing ) CALL timing_stop('flo_stp') + ! + END SUBROUTINE flo_stp + + + SUBROUTINE flo_init + !!---------------------------------------------------------------- + !! *** ROUTINE flo_init *** + !! + !! ** Purpose : Read the namelist of floats + !!---------------------------------------------------------------------- + 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,*) '~~~~~~~' + + REWIND( numnam_ref ) ! Namelist namflo in reference namelist : Floats + READ ( numnam_ref, namflo, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namflo in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namflo in configuration namelist : Floats + 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 ! compute/read initial position of floats + ! + wb(:,:,:) = wn(:,:,:) ! set wb for computation of floats trajectories at the first time step + ! + ENDIF + ! + END SUBROUTINE flo_init + + !!====================================================================== + END MODULE floats diff --git a/NEMO_4.0.4_surge/src/OCE/FLO/floblk.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/floblk.F90 new file mode 100644 index 0000000..e313d2c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/floblk.F90 @@ -0,0 +1,370 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_blk( kt ) + !!--------------------------------------------------------------------- + !! *** 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 :: 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 defined key_mpp_mpi + IF( iil(jfl) >= mig(nldi) .AND. iil(jfl) <= mig(nlei) .AND. & + ijl(jfl) >= mjg(nldj) .AND. ijl(jfl) <= mjg(nlej) ) THEN + iiloc(jfl) = iil(jfl) - mig(1) + 1 + ijloc(jfl) = ijl(jfl) - mjg(1) + 1 +# else + iiloc(jfl) = iil(jfl) + ijloc(jfl) = ijl(jfl) +# endif + + ! 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_n(iiloc(jfl)-1,ijloc(jfl) ,-ikl(jfl)) + zsurfx(2) = e2u(iiloc(jfl) ,ijloc(jfl) ) * e3u_n(iiloc(jfl) ,ijloc(jfl) ,-ikl(jfl)) + zsurfy(1) = e1v(iiloc(jfl) ,ijloc(jfl)-1) * e3v_n(iiloc(jfl) ,ijloc(jfl)-1,-ikl(jfl)) + zsurfy(2) = e1v(iiloc(jfl) ,ijloc(jfl) ) * e3v_n(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_n(iiloc(jfl),ijloc(jfl),-ikl(jfl)) + + ! + zuinfl =( ub(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl)) + un(iiloc(jfl)-1,ijloc(jfl),-ikl(jfl)) )/2.*zsurfx(1) + zuoutfl=( ub(iiloc(jfl) ,ijloc(jfl),-ikl(jfl)) + un(iiloc(jfl) ,ijloc(jfl),-ikl(jfl)) )/2.*zsurfx(2) + zvinfl =( vb(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl)) + vn(iiloc(jfl),ijloc(jfl)-1,-ikl(jfl)) )/2.*zsurfy(1) + zvoutfl=( vb(iiloc(jfl),ijloc(jfl) ,-ikl(jfl)) + vn(iiloc(jfl),ijloc(jfl) ,-ikl(jfl)) )/2.*zsurfy(2) + zwinfl =-(wb(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) & + & + wn(iiloc(jfl),ijloc(jfl),-(ikl(jfl)-1)) )/2. * zsurfz*nisobfl(jfl) + zwoutfl=-(wb(iiloc(jfl),ijloc(jfl),- ikl(jfl) ) & + & + wn(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) = 1.E99 + 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) = 1.E99 + 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) = 1.E99 + 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) > rdt ) THEN + zttfl(jfl) = (rdt-zagefl(jfl)) / zvol + zagenewfl(jfl) = rdt + 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) +# if defined key_mpp_mpi + 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 +# 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) < rdt ) 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) < rdt ) 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/NEMO_4.0.4_surge/src/OCE/FLO/flodom.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/flodom.F90 new file mode 100644 index 0000000..b5de8bd --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/flodom.F90 @@ -0,0 +1,454 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE flo_dom + !! --------------------------------------------------------------------- + !! *** 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 :: 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(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(1,jpnfl) + ENDIF + + ENDIF + + END SUBROUTINE flo_dom + + SUBROUTINE flo_add_new_floats(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) :: 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 +# if defined key_mpp_mpi + DO ji = MAX(nldi,2), nlei + DO jj = MAX(nldj,2), nlej ! NO vector opt. +# else + DO ji = 2, jpi + DO jj = 2, jpj ! NO vector opt. +# endif + ! 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_n(ji,jj,jk) <= flzz(jfl)) .AND. (gdepw_n(ji,jj,jk+1) > 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_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1) - flzz(jfl) )* ikmfl(jfl)) & + & / ( gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1) & + & - gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl) ) ) & + & + (( flzz(jfl)-gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) ) *(ikmfl(jfl)+1)) & + & / ( gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1) & + & - gdepw_n(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)) ) + 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 + !!--------------------------------------------------------------------- + !! Statement function + REAL(wp) :: fsline + REAL(wp) :: psax, psay, psbx, psby, psx, psy + fsline( psax, psay, psbx, psby, psx, psy ) = psy * ( psbx - psax ) & + & - psx * ( psby - psay ) & + & + psax * psby - psay * psbx + !!--------------------------------------------------------------------- + + ! 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 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/NEMO_4.0.4_surge/src/OCE/FLO/florst.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/florst.F90 new file mode 100644 index 0000000..e45aeb7 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/florst.F90 @@ -0,0 +1,124 @@ +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$ + !! 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(nldi)) .AND. & + &(INT(tpifl(jfl)) <= mig(nlei)) .AND. & + &(INT(tpjfl(jfl)) >= mjg(nldj)) .AND. & + &(INT(tpjfl(jfl)) <= mjg(nlej)) ) 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/NEMO_4.0.4_surge/src/OCE/FLO/flowri.F90 b/NEMO_4.0.4_surge/src/OCE/FLO/flowri.F90 new file mode 100644 index 0000000..60826a2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/FLO/flowri.F90 @@ -0,0 +1,275 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!--------------------------------------------------------------------- + !! *** 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 :: kt ! time step + + !! * 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( nldi <= iafloc .AND. iafloc <= nlei .AND. & + & nldj <= ibfloc .AND. ibfloc <= nlej ) 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_n(iafloc,ibfloc,icfl ) + zcfl * gdepw_n(iafloc,ibfloc,ic1fl) + + !save temperature, salinity and density at this position + ztem(jfl) = tsn(iafloc,ibfloc,icfl,jp_tem) + zsal (jfl) = tsn(iafloc,ibfloc,icfl,jp_sal) + zrho (jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rau0 + + 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_n(iafloc,ibfloc,icfl ) + zcfl * gdepw_n(iafloc,ibfloc,ic1fl) + + ztem(jfl) = tsn(iafloc,ibfloc,icfl,jp_tem) + zsal(jfl) = tsn(iafloc,ibfloc,icfl,jp_sal) + zrho(jfl) = (rhd(iafloc,ibfloc,icfl)+1)*rau0 + + 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 + !---------------------- + +#if defined key_iomput + 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) ) +#else + + !II-2-b Write with IOIPSL + !------------------------ + + IF( ( kt == nn_it000 .OR. MOD( kt,nn_writefl)== 0 ) .AND. lwp )THEN + + + !II-2-b-1 Open netcdf file + !------------------------- + IF( kt==nn_it000 )THEN ! Create and open + + CALL dia_nam( clname, nn_writefl, 'trajec_float' ) + clname=TRIM(clname)//".nc" + + CALL fliocrfd( clname , (/'ntraj' , ' t' /), (/ jpnfl , -1/) , numflo ) + + CALL fliodefv( numflo, 'traj_lon' , (/1,2/), v_t=flio_r8, long_name="Longitude" , units="degrees_east" ) + CALL fliodefv( numflo, 'traj_lat' , (/1,2/), v_t=flio_r8, long_name="Latitude" , units="degrees_north" ) + CALL fliodefv( numflo, 'traj_depth' , (/1,2/), v_t=flio_r8, long_name="Depth" , units="meters" ) + CALL fliodefv( numflo, 'time_counter', (/2/) , v_t=flio_r8, long_name="Time axis" & + & , units="seconds since start of the run " ) + CALL fliodefv( numflo, 'traj_temp' , (/1,2/), v_t=flio_r8, long_name="Temperature" , units="C" ) + CALL fliodefv( numflo, 'traj_salt' , (/1,2/), v_t=flio_r8, long_name="Salinity" , units="PSU" ) + 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,wp) ) + + ELSE ! Re-open + + CALL flioopfd( TRIM(clname), numflo , "WRITE" ) + + ENDIF + + !II-2-b-2 Write in netcdf file + !------------------------------- + irec = INT( (kt-nn_it000+1)/nn_writefl ) +1 + ztime = ( kt-nn_it000 + 1 ) * rdt + + CALL flioputv( numflo , 'time_counter', ztime , start=(/irec/) ) + + DO jfl = 1, jpnfl + + istart = (/jfl,irec/) + + CALL flioputv( numflo , 'traj_lon' , zlon(jfl), start=istart ) + CALL flioputv( numflo , 'traj_lat' , zlat(jfl), start=istart ) + CALL flioputv( numflo , 'traj_depth' , zdep(jfl), start=istart ) + CALL flioputv( numflo , 'traj_temp' , ztem(jfl), start=istart ) + CALL flioputv( numflo , 'traj_salt' , zsal(jfl), start=istart ) + CALL flioputv( numflo , 'traj_dens' , zrho(jfl), start=istart ) + + ENDDO + + !II-2-b-3 Close netcdf file + !--------------------------- + CALL flioclo( numflo ) + + ENDIF + +#endif + ENDIF ! netcdf writing + + END SUBROUTINE flo_wri + + !!======================================================================= +END MODULE flowri diff --git a/NEMO_4.0.4_surge/src/OCE/ICB/icb_oce.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icb_oce.F90 new file mode 100644 index 0000000..8fa86d0 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icb_oce.F90 @@ -0,0 +1,203 @@ +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 ! iceberg coordinates in the (i,j) referential (global) + 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) :: uo, vo, ui, vi, ua, va, ssh_x, ssh_y, sst, cn, hi, sss ! properties of iceberg environment + REAL(wp) :: mass_of_bits, heat_density + 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 :: uo_e, vo_e + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ff_e, tt_e, fr_e, ss_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 +#if defined key_si3 || defined key_cice + REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: hi_e, ui_e, vi_e +#endif + + !!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 :: 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<sicn_shift<1) + LOGICAL , PUBLIC :: ln_operator_splitting !: Use first order operator splitting for thermodynamics + LOGICAL , PUBLIC :: ln_passive_mode !: iceberg - ocean decoupling + REAL(wp), PUBLIC :: rn_speed_limit !: CFL speed limit for a berg + ! + ! ! Mass thresholds between iceberg classes [kg] + REAL(wp), DIMENSION(nclasses), PUBLIC :: rn_initial_mass ! Fraction of calving to apply to this class [non-dim] + REAL(wp), DIMENSION(nclasses), PUBLIC :: rn_distribution ! Ratio between effective and real iceberg mass (non-dim) + REAL(wp), DIMENSION(nclasses), PUBLIC :: rn_mass_scaling ! Total thickness of newly calved bergs [m] + REAL(wp), DIMENSION(nclasses), PUBLIC :: rn_initial_thickness ! Single instance of an icebergs type initialised in icebergs_init and updated in icebergs_run + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: src_calving, src_calving_hflx !: accumulate input ice + INTEGER , PUBLIC , SAVE :: numicb !: iceberg IO + INTEGER , PUBLIC , SAVE, DIMENSION(nkounts) :: num_bergs !: iceberg counter + INTEGER , PUBLIC , SAVE :: nicbdi, nicbei, nicbdj, nicbej !: processor bounds + REAL(wp), PUBLIC , SAVE :: ricb_left, ricb_right !: cyclical bounds + INTEGER , PUBLIC , SAVE :: nicbpack !: packing integer + INTEGER , PUBLIC , SAVE :: nktberg, nknberg !: helpers + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldpts !: nfold packed points + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbflddest !: nfold destination proc + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldproc !: nfold destination proc + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldnsend !: nfold number of bergs to send to nfold neighbour + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldexpect !: nfold expected number of bergs + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldreq !: nfold message handle (immediate send) + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: griddata !: work array for icbrst + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION icb_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ill + !!---------------------------------------------------------------------- + ! + icb_alloc = 0 + ALLOCATE( berg_grid, STAT=ill ) + icb_alloc = icb_alloc + ill + ALLOCATE( berg_grid%calving (jpi,jpj) , berg_grid%calving_hflx (jpi,jpj) , & + & berg_grid%stored_heat(jpi,jpj) , berg_grid%floating_melt(jpi,jpj) , & + & berg_grid%maxclass (jpi,jpj) , berg_grid%stored_ice (jpi,jpj,nclasses) , & + & berg_grid%tmp (jpi,jpj) , STAT=ill) + icb_alloc = icb_alloc + ill + ! + ! expanded arrays for bilinear interpolation + ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) , & + & vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) , & +#if defined key_si3 || defined key_cice + & ui_e(0:jpi+1,0:jpj+1) , & + & vi_e(0:jpi+1,0:jpj+1) , & + & hi_e(0:jpi+1,0:jpj+1) , & +#endif + & ff_e(0:jpi+1,0:jpj+1) , fr_e(0:jpi+1,0:jpj+1) , & + & tt_e(0:jpi+1,0:jpj+1) , ssh_e(0:jpi+1,0:jpj+1) , & + & ss_e(0:jpi+1,0:jpj+1) , & + & first_width(nclasses) , first_length(nclasses) , & + & src_calving (jpi,jpj) , & + & src_calving_hflx(jpi,jpj) , STAT=ill) + icb_alloc = icb_alloc + ill + + ALLOCATE( tmask_e(0:jpi+1,0:jpj+1), umask_e(0:jpi+1,0:jpj+1), vmask_e(0:jpi+1,0:jpj+1), & + & STAT=ill) + icb_alloc = icb_alloc + ill + + ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , & + & nicbfldnsend(jpni), nicbfldexpect(jpni) , nicbfldreq(jpni), STAT=ill) + icb_alloc = icb_alloc + ill + + ALLOCATE( griddata(jpi,jpj,1), STAT=ill ) + icb_alloc = icb_alloc + ill + + CALL mpp_sum ( 'icb_oce', icb_alloc ) + IF( icb_alloc > 0 ) CALL ctl_warn('icb_alloc: allocation of arrays failed') + ! + END FUNCTION icb_alloc + + !!====================================================================== +END MODULE icb_oce diff --git a/NEMO_4.0.4_surge/src/OCE/ICB/icbclv.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbclv.F90 new file mode 100644 index 0000000..1051602 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbclv.F90 @@ -0,0 +1,186 @@ +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 icb_oce ! iceberg variables + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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 = 1, jpj + DO ji = 1, jpi + 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 ) + newpt%yj = REAL( mjg(jj), wp ) + ! + 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%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 + ! + DO jn = 1, nclasses + CALL lbc_lnk( 'icbclv', berg_grid%stored_ice(:,:,jn), 'T', 1._wp ) + END DO + CALL lbc_lnk( 'icbclv', berg_grid%stored_heat, 'T', 1._wp ) + ! + 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/NEMO_4.0.4_surge/src/OCE/ICB/icbdia.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbdia.F90 new file mode 100644 index 0000000..530c3a4 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbdia.F90 @@ -0,0 +1,616 @@ +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 + INTEGER , DIMENSION(nclasses) :: nbergs_calved_by_class + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + 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 = 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 > 0 ) WRITE( numicb, '("speeding tickets issued = ",i6)') nspeeding_tickets + ENDIF + ! + nbergs_start = nbergs_end + stored_start = stored_end + nbergs_melted = 0 + nbergs_calved = 0 + nbergs_calved_by_class(:) = 0 + nspeeding_tickets = 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 ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + 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 + !!---------------------------------------------------------------------- + ! + 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_dt_e1e2 ! J/m2/s + berg_melt_qlat (ki,kj) = berg_melt_qlat (ki,kj) + pheat_latent * pz1_dt_e1e2 ! J/m2/s + 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/NEMO_4.0.4_surge/src/OCE/ICB/icbdyn.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbdyn.F90 new file mode 100644 index 0000000..5b84e3b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbdyn.F90 @@ -0,0 +1,383 @@ +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 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$ + !! 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( berg , zxi1, ze1, zuvel1, zuvel1, zax1, & + & zyj1, ze2, zvvel1, zvvel1, zay1, zdt_2 ) + ! + 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( zxi2, zxi1, zu1, & + & zyj2, zyj1, zv1, ll_bounced ) + + ! !** A2 = A(X2,V2) + CALL icb_accel( berg , zxi2, ze1, zuvel2, zuvel1, zax2, & + & zyj2, ze2, zvvel2, zvvel1, zay2, zdt_2 ) + ! + 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( zxi3, zxi1, zu3, & + & zyj3, zyj1, zv3, ll_bounced ) + + ! !** A3 = A(X3,V3) + CALL icb_accel( berg , zxi3, ze1, zuvel3, zuvel1, zax3, & + & zyj3, ze2, zvvel3, zvvel1, zay3, zdt ) + ! + 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( zxi4, zxi1, zu4, & + & zyj4, zyj1, zv4, ll_bounced ) + + ! !** A4 = A(X4,V4) + CALL icb_accel( berg , zxi4, ze1, zuvel4, zuvel1, zax4, & + & zyj4, ze2, zvvel4, zvvel1, zay4, zdt ) + + 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( 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 + + ! update actual position + pt%lon = icb_utl_bilin_x(glamt, pt%xi, pt%yj ) + pt%lat = icb_utl_bilin(gphit, pt%xi, pt%yj, 'T' ) + + berg => berg%next ! switch to the next berg + ! + END DO !== end loop over all bergs ==! + ! + END SUBROUTINE icb_dyn + + + SUBROUTINE icb_ground( 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 + !!---------------------------------------------------------------------- + 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 :: ibounce_method + !!---------------------------------------------------------------------- + ! + ld_bounced = .FALSE. + ! + ii0 = INT( pi0+0.5 ) ; ij0 = INT( pj0+0.5 ) ! initial gridpoint position (T-cell) + ii = INT( pi +0.5 ) ; ij = INT( pj +0.5 ) ! 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 ) + ! + IF( tmask(ii,ij,1) /= 0._wp ) RETURN ! berg reach a new t-cell, but an ocean one + ! + ! 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( berg , pxi, pe1, puvel, puvel0, pax, & + & pyj, pe2, pvvel, pvvel0, pay, pdt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_accel *** + !! + !! ** Purpose : compute the iceberg acceleration. + !! + !! ** Method : - sum the terms in the momentum budget + !!---------------------------------------------------------------------- + TYPE(iceberg ), POINTER, INTENT(in ) :: berg ! berg + 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 + REAL(wp) :: zuo, zui, zua, zuwave, zssh_x, zsst, zcn, zhi, zsss + REAL(wp) :: zvo, 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 + 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 + !!---------------------------------------------------------------------- + + ! Interpolate gridded fields to berg + nknberg = berg%number(1) + CALL icb_utl_interp( pxi, pe1, zuo, zui, zua, zssh_x, & + & pyj, pe2, zvo, zvi, zva, zssh_y, zsst, zcn, zhi, zff, zsss ) + + zM = berg%current_point%mass + zT = berg%current_point%thickness ! total thickness + zD = ( rn_rho_bergs / pp_rho_seawater ) * 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 - zuo ; zvwave = zva - zvo ! 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 * 0.02025 * zwmod ! This is "a", the wave amplitude + zLwavelength = 0.32 * 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 * zLwavelength + zLtop = 0.25 * zLwavelength + zCr = pp_Cr0 * MIN( MAX( 0., (zL-zLcutoff) / ((zLtop-zLcutoff)+1.e-30)) , 1.) ! Wave radiation coefficient + ! ! fitted to graph from Carrieres et al., POAC Drift Model. + zwave_rad = 0.5 * pp_rho_seawater / zM * zCr * grav * zampl * MIN( zampl,zF ) * (2.*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. ; zvwave=0. ; zwave_rad=0. ! ... and only when wind is present. !!gm wave_rad=0. is useless + ENDIF + + ! Weighted drag coefficients + z_ocn = pp_rho_seawater / zM * (0.5*pp_Cd_wv*zW*(zD_hi)+pp_Cd_wh*zW*zL) + z_atm = pp_rho_air / zM * (0.5*pp_Cd_av*zW*zF +pp_Cd_ah*zW*zL) + z_ice = pp_rho_ice / zM * (0.5*pp_Cd_iv*zW*zhi ) + IF( abs(zui) + abs(zvi) == 0._wp ) z_ice = 0._wp + + zuveln = puvel ; zvveln = pvvel ! Copy starting uvel, vvel + ! + DO itloop = 1, 2 ! Iterate on drag coefficients + ! + zus = 0.5 * ( zuveln + puvel ) + zvs = 0.5 * ( 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-zuo) -zdrag_atm*(puvel-zua) -zdrag_ice*(puvel-zui) + !zaye=-zff*puvel -grav*zssh_y +zwave_rad*zvwave & + ! -zdrag_ocn*(pvvel-zvo) -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 + zspeed_new = zloc_dx / pdt * rn_speed_limit ! 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 + 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/NEMO_4.0.4_surge/src/OCE/ICB/icbini.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbini.F90 new file mode 100644 index 0000000..3365428 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbini.F90 @@ -0,0 +1,498 @@ +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 + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 (rdt*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 gridded fields + IF( icb_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'icb_alloc : unable to allocate arrays' ) + ! + ! ! initialised variable with extra haloes to zero + uo_e(:,:) = 0._wp ; vo_e(:,:) = 0._wp ; + ua_e(:,:) = 0._wp ; va_e(:,:) = 0._wp ; + ff_e(:,:) = 0._wp ; tt_e(:,:) = 0._wp ; + fr_e(:,:) = 0._wp ; ss_e(:,:) = 0._wp ; +#if defined key_si3 + hi_e(:,:) = 0._wp ; + ui_e(:,:) = 0._wp ; vi_e(:,:) = 0._wp ; +#endif + 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(:) + + 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 = 1, jpj + DO ji = 1, jpi + 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 = nlcj/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 = nlci/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,nlcj/2) ) + jj = INT( i3/nicbpack ) + ricb_left = REAL( i3 - nicbpack*jj, wp ) + i1 = MIN( nicbei+1, jpi ) + i3 = INT( src_calving(i1,nlcj/2) ) + jj = INT( i3/nicbpack ) + ricb_right = REAL( i3 - nicbpack*jj, wp ) + + ! north fold + IF( npolj > 0 ) 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,*) 'nldi, nlei ', nldi, nlei + WRITE(numicb,*) 'nldj, nlej ', nldj, nlej + 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 = nlcj/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 = nlci/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( npolj > 0 ) 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 ) + ! + ! 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_data, '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), wp ) + localpt%yj = REAL( mjg(jj), wp ) + localpt%lon = icb_utl_bilin(glamt, localpt%xi, localpt%yj, 'T' ) + localpt%lat = icb_utl_bilin(gphit, localpt%xi, localpt%yj, 'T' ) + 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 + 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 , & + & nn_test_icebergs , rn_test_box , ln_use_calving , & + & rn_speed_limit , cn_dir, sn_icb + !!---------------------------------------------------------------------- + +#if defined key_agrif + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : AGRIF is not compatible with namelist namberg : ' + WRITE(numout,*) '~~~~~~~ definition of rn_initial_mass(nclasses) with nclasses as PARAMETER ' + WRITE(numout,*) + WRITE(numout,*) ' ==>>> force NO icebergs used. The namelist namberg is not read' + ENDIF + ln_icebergs = .false. + RETURN +#else + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'icb_nam : iceberg initialization through namberg namelist read' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF +#endif + ! !== read namelist ==! + REWIND( numnam_ref ) ! Namelist namberg in reference namelist : Iceberg parameters + READ ( numnam_ref, namberg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namberg in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namberg in configuration namelist : Iceberg parameters + 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,*) ' Shift of sea-ice concentration in erosion flux modulation ', & + & '(0<sicn_shift<1) rn_sicn_shift = ', rn_sicn_shift + WRITE(numout,*) ' Do not add freshwater flux from icebergs to ocean ', & + & ' passive_mode = ', ln_passive_mode + WRITE(numout,*) ' Create icebergs in absence of a restart file nn_test_icebergs = ', nn_test_icebergs + WRITE(numout,*) ' in lon/lat box = ', rn_test_box + WRITE(numout,*) ' Use calving data even if nn_test_icebergs > 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/NEMO_4.0.4_surge/src/OCE/ICB/icblbc.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icblbc.F90 new file mode 100644 index 0000000..7417f28 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icblbc.F90 @@ -0,0 +1,926 @@ +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 + +#if defined key_mpp_mpi + +!$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 + +#endif + + PUBLIC icb_lbc + PUBLIC icb_lbc_mpp + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + INTEGER :: iine + !!---------------------------------------------------------------------- + + !! periodic east/west boundaries + !! ============================= + + IF( l_Iperio ) THEN + + this => first_berg + DO WHILE( ASSOCIATED(this) ) + pt => this%current_point + iine = INT( pt%xi + 0.5 ) + IF( iine > mig(nicbei) ) THEN + pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp + ELSE IF( iine < mig(nicbdi) ) 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( npolj /= 0 ) 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( ijne .GT. mjg(nicbej) ) 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 + +#if defined key_mpp_mpi + !!---------------------------------------------------------------------- + !! 'key_mpp_mpi' 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 :: iine, ijne + 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( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe + IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea + IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso + IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono + ! + ! at northern line of processors with north fold handle bergs differently + IF( npolj > 0 ) 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 + WRITE(numicb,*) 'processor nbondi: ', nbondi + WRITE(numicb,*) 'processor nbondj: ', nbondj + 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 + iine = INT( pt%xi + 0.5 ) + IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) 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. iine < mig(nicbdi) ) 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 + + SELECT CASE ( nbondi ) + CASE( -1 ) + zwebergs(1) = ibergs_to_send_e + CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) + CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) + CALL mpi_wait( iml_req1, iml_stat, iml_err ) + ibergs_rcvd_from_e = INT( zewbergs(2) ) + CASE( 0 ) + zewbergs(1) = ibergs_to_send_w + zwebergs(1) = ibergs_to_send_e + CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) + CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) + CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) + CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) + CALL mpi_wait( iml_req2, iml_stat, iml_err ) + CALL mpi_wait( iml_req3, iml_stat, iml_err ) + ibergs_rcvd_from_e = INT( zewbergs(2) ) + ibergs_rcvd_from_w = INT( zwebergs(2) ) + CASE( 1 ) + zewbergs(1) = ibergs_to_send_w + CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) + CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) + CALL mpi_wait( iml_req4, iml_stat, iml_err ) + ibergs_rcvd_from_w = INT( zwebergs(2) ) + END SELECT + IF( nn_verbose_level >= 3) THEN + WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e + CALL flush(numicb) + ENDIF + + SELECT CASE ( nbondi ) + CASE( -1 ) + IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) + 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_to_send_e > 0 ) CALL mpi_wait( iml_req1, 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) + ENDDO + CASE( 0 ) + 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) + ENDDO + CASE( 1 ) + IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) + 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_req4, iml_stat, iml_err ) + 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 + END SELECT + + ! 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 + ijne = INT( pt%yj + 0.5 ) + IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) 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. ijne .LT. mjg(nicbdj) ) 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) + + SELECT CASE ( nbondj ) + CASE( -1 ) + zsnbergs(1) = ibergs_to_send_n + CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) + CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) + CALL mpi_wait( iml_req1, iml_stat, iml_err ) + ibergs_rcvd_from_n = INT( znsbergs(2) ) + CASE( 0 ) + znsbergs(1) = ibergs_to_send_s + zsnbergs(1) = ibergs_to_send_n + CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) + CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) + CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) + CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) + CALL mpi_wait( iml_req2, iml_stat, iml_err ) + CALL mpi_wait( iml_req3, iml_stat, iml_err ) + ibergs_rcvd_from_n = INT( znsbergs(2) ) + ibergs_rcvd_from_s = INT( zsnbergs(2) ) + CASE( 1 ) + znsbergs(1) = ibergs_to_send_s + CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) + CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) + CALL mpi_wait( iml_req4, iml_stat, iml_err ) + ibergs_rcvd_from_s = INT( zsnbergs(2) ) + END SELECT + if( nn_verbose_level >= 3) then + write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n + call flush(numicb) + endif + + SELECT CASE ( nbondj ) + CASE( -1 ) + IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) + 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_to_send_n > 0 ) CALL mpi_wait( iml_req1, 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 + CASE( 0 ) + 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) + ENDDO + CASE( 1 ) + IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) + 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_req4, iml_stat, iml_err ) + 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 + END SELECT + + 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( npolj /= 0 .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 + iine = INT( pt%xi + 0.5 ) + ijne = INT( pt%yj + 0.5 ) + IF( iine .LT. mig(nicbdi) .OR. & + iine .GT. mig(nicbei) .OR. & + ijne .LT. mjg(nicbdj) .OR. & + ijne .GT. mjg(nicbej)) THEN + i = i + 1 + WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne + 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 ) + ijne = INT( pt%yj + 0.5 ) + iproc = nicbflddest(mi1(iine)) + IF( ijne .GT. mjg(nicbej) ) 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 ) + ijne = INT( pt%yj + 0.5 ) + ipts = nicbfldpts (mi1(iine)) + iproc = nicbflddest(mi1(iine)) + IF( ijne .GT. mjg(nicbej) ) 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 + +#else + !!---------------------------------------------------------------------- + !! Default case: Dummy module share memory computing + !!---------------------------------------------------------------------- + SUBROUTINE icb_lbc_mpp() + WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!' + END SUBROUTINE icb_lbc_mpp +#endif + + !!====================================================================== +END MODULE icblbc diff --git a/NEMO_4.0.4_surge/src/OCE/ICB/icbrst.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbrst.F90 new file mode 100644 index 0000000..1a25d4d --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbrst.F90 @@ -0,0 +1,437 @@ +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 ioipsl, ONLY : ju2ymds ! for calendar + 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$ + !! 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_ocerst_indir) + IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' + cl_filename = TRIM(cn_ocerst_in)//'_icebergs' + 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 ) + ij = INT( localpt%yj + 0.5 ) + ! Only proceed if this iceberg is on the local processor (excluding halos). + IF ( ii .GE. nldi+nimpp-1 .AND. ii .LE. nlei+nimpp-1 .AND. & + & ij .GE. nldj+njmpp-1 .AND. ij .LE. nlej+njmpp-1 ) 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_autoglo, 'calving' , src_calving ) + CALL iom_get( ncid, jpdom_autoglo, 'calving_hflx', src_calving_hflx ) + CALL iom_get( ncid, jpdom_autoglo, 'stored_heat' , berg_grid%stored_heat ) + CALL iom_get( ncid, jpdom_autoglo_xy, 'stored_ice' , berg_grid%stored_ice, kstart=(/1,1,1/), kcount=(/1,1,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 + INTEGER :: iyear, imonth, iday + REAL (wp) :: zsec + REAL (wp) :: zfjulday + CHARACTER(len=256) :: cl_path + CHARACTER(len=256) :: cl_filename + CHARACTER(LEN=20) :: clkt ! ocean time-step deine as a character + 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. + cl_path = TRIM(cn_ocerst_outdir) + IF( cl_path(LEN_TRIM(cl_path):) /= '/' ) cl_path = TRIM(cl_path) // '/' + IF ( ln_rstdate ) THEN + zfjulday = fjulday + rdt / rday + 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(clkt, '(i4.4,2i2.2)') iyear, imonth, iday + ELSE + IF( kt > 999999999 ) THEN ; WRITE(clkt, * ) kt + ELSE ; WRITE(clkt, '(i8.8)') kt + ENDIF + ENDIF + cl_filename = TRIM(cexper)//"_icebergs_"//TRIM(ADJUSTL(clkt))//"_restart" + 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', jpi, ix_dim) + IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim x failed') + + nret = NF90_DEF_DIM(ncid, 'y', jpj, 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' , (/jpiglo, jpjglo/) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/jpi , jpj /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/nimpp , njmpp /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/nimpp + jpi - 1 , njmpp + jpj - 1 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/nldi - 1 , nldj - 1 /) ) + nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/jpi - nlei , jpj - nlej /) ) + 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) = jpi + nlngth3(2) = jpj + nlngth3(3) = 1 + + DO jn=1,nclasses + griddata(:,:,1) = berg_grid%stored_ice(:,:,jn) + nstrt3(3) = jn + nret = NF90_PUT_VAR( ncid, nsiceid, griddata, 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(:,:) ) + 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(:,:) ) + 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(:,:) ) + 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/NEMO_4.0.4_surge/src/OCE/ICB/icbstp.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbstp.F90 new file mode 100644 index 0000000..8b4b80f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbstp.F90 @@ -0,0 +1,173 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_stp( kt ) + !!---------------------------------------------------------------------- + !! *** 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 + ! + LOGICAL :: ll_sample_traj, ll_budget, ll_verbose ! local logical + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('icb_stp') + + ! !== start of timestep housekeeping ==! + ! + nktberg = kt + ! + 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() ! 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 key_iomput 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/NEMO_4.0.4_surge/src/OCE/ICB/icbthm.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbthm.F90 new file mode 100644 index 0000000..a5bc6f9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbthm.F90 @@ -0,0 +1,253 @@ +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$ + !! 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 + REAL(wp) :: zM, zT, zW, zL, zSST, zVol, zLn, zWn, zTn, znVol, zIC, zDn + REAL(wp) :: zSSS, zfzpt + REAL(wp) :: zMv, zMe, zMb, zmelt, zdvo, zdva, zdM, zSs, zdMe, zdMb, zdMv + 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 + TYPE(iceberg), POINTER :: this, next + TYPE(point) , POINTER :: pt + ! + COMPLEX(wp), DIMENSION(jpi,jpj) :: cicb_melt, cicb_hflx + !!---------------------------------------------------------------------- + ! + !! initialiaze cicb_melt and cicb_heat + cicb_melt = CMPLX( 0.e0, 0.e0, wp ) + cicb_hflx = CMPLX( 0.e0, 0.e0, wp ) + ! + 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%e1, pt%uo, pt%ui, pt%ua, pt%ssh_x, & + & pt%yj, pt%e2, pt%vo, pt%vi, pt%va, pt%ssh_y, & + & pt%sst, pt%cn, pt%hi, zff, pt%sss ) + ! + 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 + ! D = (rn_rho_bergs/pp_rho_seawater)*zT ! draught (keel depth) + ! F = zT - D ! freeboard + 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 ) + ij = INT( zyj + 0.5 ) + ij = mj1( ij ) + zVol = zT * zW * zL + + ! Environment + zdvo = SQRT( (pt%uvel-pt%uo)**2 + (pt%vvel-pt%vo)**2 ) + zdva = SQRT( (pt%ua -pt%uo)**2 + (pt%va -pt%vo)**2 ) + 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) + zMv = MAX( 7.62d-3*zSST+1.29d-3*(zSST**2) , 0._wp ) * z1_rday ! Buoyant convection at sides (eqn M.A10) + IF ( zSST > zfzpt ) THEN ! Calculate basal melting only if SST above freezing point + zMb = MAX( 0.58_wp*(zdvo**0.8_wp)*(zSST+4.0_wp)/(zL**0.2_wp) , 0._wp ) * z1_rday ! Basal turbulent melting (eqn M.A7 ) + ELSE + zMb = 0._wp ! No basal melting if SST below freezing point + ENDIF + zMe = MAX( z1_12*(zSST+2.)*zSs*(1._wp+COS(rpi*(zIC**3))) , 0._wp ) * z1_rday ! Wave erosion (eqn M.A8 ) + + 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*(zdvo**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, wp ), 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, wp ), 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 ) + 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 = ( rn_rho_bergs / pp_rho_seawater ) * 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 ? + + 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,wp) ! kg/m2/s + berg_grid%calving_hflx = REAL(cicb_hflx,wp) + ! + ! 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/NEMO_4.0.4_surge/src/OCE/ICB/icbtrj.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbtrj.F90 new file mode 100644 index 0000000..dfb0407 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbtrj.F90 @@ -0,0 +1,287 @@ +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 + INTEGER :: n_dim, m_dim + INTEGER :: ntrajid + INTEGER :: numberid, nstepid, nscaling_id + INTEGER :: nlonid, nlatid, nxid, nyid, nuvelid, nvvelid, nmassid + INTEGER :: nuoid, nvoid, 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$ + !! 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(wp) :: zfjulday, zsec + CHARACTER(len=80) :: cl_filename + CHARACTER(LEN=8 ) :: cldate_ini, cldate_end + CHARACTER(LEN=12) :: clfmt ! writing format + 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 + rdt / 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, 'uto' , NF90_DOUBLE, n_dim , nuoid ) + iret = NF90_DEF_VAR( ntrajid, 'vto' , NF90_DOUBLE, n_dim , nvoid ) + 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, nuoid , 'long_name', 'ocean u component' ) + iret = NF90_PUT_ATT( ntrajid, nuoid , 'units' , 'm/s' ) + iret = NF90_PUT_ATT( ntrajid, nvoid , 'long_name', 'ocean v component' ) + iret = NF90_PUT_ATT( ntrajid, nvoid , '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, nuoid , pt%uo , (/ jn /) ) + iret = NF90_PUT_VAR( ntrajid, nvoid , pt%vo , (/ 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/NEMO_4.0.4_surge/src/OCE/ICB/icbutl.F90 b/NEMO_4.0.4_surge/src/OCE/ICB/icbutl.F90 new file mode 100644 index 0000000..a6ea670 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ICB/icbutl.F90 @@ -0,0 +1,826 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! icb_utl_interp : + !! icb_utl_bilin : + !! icb_utl_bilin_e : + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + 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 +#if defined key_si3 + USE ice, ONLY: u_ice, v_ice, hm_i ! SI3 variables + USE icevar ! ice_var_sshdyn + USE sbc_ice, ONLY: snwice_mass, snwice_mass_b +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC icb_utl_copy ! routine called in icbstp module + PUBLIC icb_utl_interp ! routine called in icbdyn, icbthm modules + PUBLIC icb_utl_bilin ! routine called in icbini, icbdyn modules + PUBLIC icb_utl_bilin_x ! 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE icb_utl_copy() + !!---------------------------------------------------------------------- + !! *** ROUTINE icb_utl_copy *** + !! + !! ** Purpose : iceberg initialization. + !! + !! ** Method : - blah blah + !!---------------------------------------------------------------------- +#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 +#endif + ! 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 + + uo_e(1:jpi,1:jpj) = ssu_m(:,:) * umask(:,:,1) + vo_e(1:jpi,1:jpj) = ssv_m(:,:) * vmask(:,:,1) + ff_e(1:jpi,1:jpj) = ff_f (:,:) + tt_e(1:jpi,1:jpj) = sst_m(:,:) + ss_e(1:jpi,1:jpj) = sss_m(:,:) + fr_e(1:jpi,1:jpj) = fr_i (:,:) + ua_e(1:jpi,1:jpj) = utau (:,:) * umask(:,:,1) ! maybe mask useless because mask applied in sbcblk + va_e(1:jpi,1:jpj) = vtau (:,:) * vmask(:,:,1) ! maybe mask useless because mask applied in sbcblk + ! + CALL lbc_lnk_icb( 'icbutl', uo_e, 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', vo_e, 'V', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ff_e, 'F', +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 ) + CALL lbc_lnk_icb( 'icbutl', fr_e, 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', tt_e, 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ss_e, 'T', +1._wp, 1, 1 ) +#if defined key_si3 + hi_e(1:jpi, 1:jpj) = hm_i (:,:) + ui_e(1:jpi, 1:jpj) = u_ice(:,:) + vi_e(1:jpi, 1:jpj) = v_ice(:,:) + ! + ! compute ssh slope using ssh_lead if embedded + zssh_lead_m(:,:) = ice_var_sshdyn(ssh_m, snwice_mass, snwice_mass_b) + ssh_e(1:jpi, 1:jpj) = zssh_lead_m(:,:) * tmask(:,:,1) + ! + CALL lbc_lnk_icb( 'icbutl', hi_e , 'T', +1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', ui_e , 'U', -1._wp, 1, 1 ) + CALL lbc_lnk_icb( 'icbutl', vi_e , 'V', -1._wp, 1, 1 ) +#else + ssh_e(1:jpi, 1:jpj) = ssh_m(:,:) * tmask(:,:,1) +#endif + CALL lbc_lnk_icb( 'icbutl', ssh_e, 'T', +1._wp, 1, 1 ) + ! + END SUBROUTINE icb_utl_copy + + + SUBROUTINE icb_utl_interp( pi, pe1, puo, pui, pua, pssh_i, & + & pj, pe2, pvo, pvi, pva, pssh_j, & + & psst, pcn, phi, pff, psss ) + !!---------------------------------------------------------------------- + !! *** 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) :: pe1, pe2 ! i- and j scale factors + REAL(wp), INTENT( out) :: puo, pvo, pui, pvi, pua, pva ! ocean, ice and wind speeds + REAL(wp), INTENT( out) :: pssh_i, pssh_j ! ssh i- & j-gradients + REAL(wp), INTENT( out) :: psst, pcn, phi, pff, psss ! SST, ice concentration, ice thickness, Coriolis, SSS + ! + REAL(wp) :: zcd, zmod ! local scalars + !!---------------------------------------------------------------------- + + pe1 = icb_utl_bilin_e( e1t, e1u, e1v, e1f, pi, pj ) ! scale factors + pe2 = icb_utl_bilin_e( e2t, e2u, e2v, e2f, pi, pj ) + ! + puo = icb_utl_bilin_h( uo_e, pi, pj, 'U', .false. ) ! ocean velocities + pvo = icb_utl_bilin_h( vo_e, pi, pj, 'V', .false. ) + psst = icb_utl_bilin_h( tt_e, pi, pj, 'T', .true. ) ! SST + psss = icb_utl_bilin_h( ss_e, pi, pj, 'T', .true. ) ! SSS + pcn = icb_utl_bilin_h( fr_e, pi, pj, 'T', .true. ) ! ice concentration + pff = icb_utl_bilin_h( ff_e, pi, pj, 'F', .false. ) ! Coriolis parameter + ! + pua = icb_utl_bilin_h( ua_e, pi, pj, 'U', .true. ) ! 10m wind + pva = icb_utl_bilin_h( va_e, pi, pj, 'V', .true. ) ! 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 + +#if defined key_si3 + pui = icb_utl_bilin_h( ui_e , pi, pj, 'U', .false. ) ! sea-ice velocities + pvi = icb_utl_bilin_h( vi_e , pi, pj, 'V', .false. ) + phi = icb_utl_bilin_h( hi_e , pi, pj, 'T', .true. ) ! ice thickness +#else + pui = 0._wp + pvi = 0._wp + phi = 0._wp +#endif + + ! Estimate SSH gradient in i- and j-direction (centred evaluation) + pssh_i = ( icb_utl_bilin_h( ssh_e, pi+0.1_wp, pj, 'T', .true. ) - & + & icb_utl_bilin_h( ssh_e, pi-0.1_wp, pj, 'T', .true. ) ) / ( 0.2_wp * pe1 ) + pssh_j = ( icb_utl_bilin_h( ssh_e, pi, pj+0.1_wp, 'T', .true. ) - & + & icb_utl_bilin_h( ssh_e, pi, pj-0.1_wp, 'T', .true. ) ) / ( 0.2_wp * pe2 ) + ! + END SUBROUTINE icb_utl_interp + + + REAL(wp) FUNCTION icb_utl_bilin_h( pfld, pi, pj, cd_type, plmask ) + !!---------------------------------------------------------------------- + !! *** 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) , INTENT(in) :: pi, pj ! targeted coordinates in (i,j) referential + CHARACTER(len=1) , INTENT(in) :: cd_type ! type of pfld array grid-points: = T , U , V or F points + LOGICAL , INTENT(in) :: plmask ! special treatment of mask point + ! + INTEGER :: ii, ij ! local integer + REAL(wp) :: zi, zj ! local real + REAL(wp) :: zw1, zw2, zw3, zw4 + REAL(wp), DIMENSION(4) :: zmask + !!---------------------------------------------------------------------- + ! + 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 + ii = MAX(0, INT( pi )) + ij = MAX(0, INT( pj )) ! T-point + zi = pi - REAL(ii,wp) + zj = pj - REAL(ij,wp) + CASE ( 'U' ) + ii = MAX(0, INT( pi-0.5_wp )) + ij = MAX(0, INT( pj )) ! U-point + zi = pi - 0.5_wp - REAL(ii,wp) + zj = pj - REAL(ij,wp) + CASE ( 'V' ) + ii = MAX(0, INT( pi )) + ij = MAX(0, INT( pj-0.5_wp )) ! V-point + zi = pi - REAL(ii,wp) + zj = pj - 0.5_wp - REAL(ij,wp) + CASE ( 'F' ) + ii = MAX(0, INT( pi-0.5_wp )) + ij = MAX(0, INT( pj-0.5_wp )) ! F-point + zi = pi - 0.5_wp - REAL(ii,wp) + zj = pj - 0.5_wp - REAL(ij,wp) + END SELECT + ! + ! find position in this processor. Prevent near edge problems (see #1389) + ! (PM) will be useless if extra halo is used in NEMO + ! + IF ( ii <= mig(1)-1 ) THEN ; ii = 0 + ELSEIF( ii > mig(jpi) ) THEN ; ii = jpi + ELSE ; ii = mi1(ii) + ENDIF + IF ( ij <= mjg(1)-1 ) THEN ; ij = 0 + ELSEIF( ij > mjg(jpj) ) THEN ; ij = jpj + ELSE ; ij = mj1(ij) + ENDIF + ! + ! define mask array + IF (plmask) THEN + ! land value is not used in the interpolation + SELECT CASE ( cd_type ) + CASE ( 'T' ) + zmask = (/tmask_e(ii,ij), tmask_e(ii+1,ij), tmask_e(ii,ij+1), tmask_e(ii+1,ij+1)/) + CASE ( 'U' ) + zmask = (/umask_e(ii,ij), umask_e(ii+1,ij), umask_e(ii,ij+1), umask_e(ii+1,ij+1)/) + CASE ( 'V' ) + zmask = (/vmask_e(ii,ij), vmask_e(ii+1,ij), vmask_e(ii,ij+1), vmask_e(ii+1,ij+1)/) + CASE ( 'F' ) + ! F case only used for coriolis, ff_f is not mask so zmask = 1 + zmask = 1. + END SELECT + ELSE + ! land value is used during interpolation + zmask = 1. + END iF + ! + ! compute weight + zw1 = zmask(1) * (1._wp-zi) * (1._wp-zj) + zw2 = zmask(2) * zi * (1._wp-zj) + zw3 = zmask(3) * (1._wp-zi) * zj + zw4 = zmask(4) * zi * zj + ! + ! compute interpolated value + icb_utl_bilin_h = ( pfld(ii,ij)*zw1 + pfld(ii+1,ij)*zw2 + pfld(ii,ij+1)*zw3 + pfld(ii+1,ij+1)*zw4 ) / MAX(1.e-20, zw1+zw2+zw3+zw4) + ! + END FUNCTION icb_utl_bilin_h + + + REAL(wp) FUNCTION icb_utl_bilin( pfld, pi, pj, cd_type ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfld ! field to be interpolated + REAL(wp) , INTENT(in) :: pi, pj ! targeted coordinates in (i,j) referential + CHARACTER(len=1) , INTENT(in) :: cd_type ! type of pfld array grid-points: = T , U , V or F points + ! + INTEGER :: ii, ij ! local integer + REAL(wp) :: zi, zj ! local real + !!---------------------------------------------------------------------- + ! + 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 + ii = MAX(1, INT( pi )) + ij = MAX(1, INT( pj )) ! T-point + zi = pi - REAL(ii,wp) + zj = pj - REAL(ij,wp) + CASE ( 'U' ) + ii = MAX(1, INT( pi-0.5 )) + ij = MAX(1, INT( pj )) ! U-point + zi = pi - 0.5 - REAL(ii,wp) + zj = pj - REAL(ij,wp) + CASE ( 'V' ) + ii = MAX(1, INT( pi )) + ij = MAX(1, INT( pj-0.5 )) ! V-point + zi = pi - REAL(ii,wp) + zj = pj - 0.5 - REAL(ij,wp) + CASE ( 'F' ) + ii = MAX(1, INT( pi-0.5 )) + ij = MAX(1, INT( pj-0.5 )) ! F-point + zi = pi - 0.5 - REAL(ii,wp) + zj = pj - 0.5 - REAL(ij,wp) + END SELECT + ! + ! find position in this processor. Prevent near edge problems (see #1389) + IF ( ii < mig( 1 ) ) THEN ; ii = 1 + ELSEIF( ii > mig(jpi) ) THEN ; ii = jpi + ELSE ; ii = mi1(ii) + ENDIF + IF ( ij < mjg( 1 ) ) THEN ; ij = 1 + ELSEIF( ij > mjg(jpj) ) THEN ; ij = jpj + ELSE ; ij = mj1(ij) + ENDIF + ! + IF( ii == jpi ) ii = ii-1 + IF( ij == jpj ) ij = ij-1 + ! + icb_utl_bilin = ( pfld(ii,ij ) * (1.-zi) + pfld(ii+1,ij ) * zi ) * (1.-zj) & + & + ( pfld(ii,ij+1) * (1.-zi) + pfld(ii+1,ij+1) * zi ) * zj + ! + END FUNCTION icb_utl_bilin + + + REAL(wp) FUNCTION icb_utl_bilin_x( pfld, pi, pj ) + !!---------------------------------------------------------------------- + !! *** FUNCTION icb_utl_bilin_x *** + !! + !! ** Purpose : bilinear interpolation at berg location depending on the grid-point type + !! Special case for interpolating longitude + !! + !! !!gm CAUTION an optional argument should be added to handle + !! the slip/no-slip conditions ==>>> to be done later + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pfld ! field to be interpolated + REAL(wp) , INTENT(in) :: pi, pj ! targeted coordinates in (i,j) referential + ! + INTEGER :: ii, ij ! local integer + REAL(wp) :: zi, zj ! local real + REAL(wp) :: zret ! local real + REAL(wp), DIMENSION(4) :: z4 + !!---------------------------------------------------------------------- + ! + ! 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 + ii = MAX(1, INT( pi )) + ij = MAX(1, INT( pj )) ! T-point + zi = pi - REAL(ii,wp) + zj = pj - REAL(ij,wp) + ! + ! find position in this processor. Prevent near edge problems (see #1389) + IF ( ii < mig( 1 ) ) THEN ; ii = 1 + ELSEIF( ii > mig(jpi) ) THEN ; ii = jpi + ELSE ; ii = mi1(ii) + ENDIF + IF ( ij < mjg( 1 ) ) THEN ; ij = 1 + ELSEIF( ij > mjg(jpj) ) THEN ; ij = jpj + ELSE ; ij = mj1(ij) + ENDIF + ! + IF( ii == jpi ) ii = ii-1 + IF( ij == jpj ) ij = ij-1 + ! + z4(1) = pfld(ii ,ij ) + z4(2) = pfld(ii+1,ij ) + z4(3) = pfld(ii ,ij+1) + z4(4) = pfld(ii+1,ij+1) + IF( MAXVAL(z4) - MINVAL(z4) > 90._wp ) THEN + WHERE( z4 < 0._wp ) z4 = z4 + 360._wp + ENDIF + ! + zret = (z4(1) * (1.-zi) + z4(2) * zi) * (1.-zj) + (z4(3) * (1.-zi) + z4(4) * zi) * zj + IF( zret > 180._wp ) zret = zret - 360._wp + icb_utl_bilin_x = zret + ! + END FUNCTION icb_utl_bilin_x + + + 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) :: pet, peu, pev, pef ! horizontal scale factor to be interpolated at t-,u-,v- & f-pts + REAL(wp) , INTENT(in) :: pi, pj ! targeted coordinates in (i,j) referential + ! + INTEGER :: ii, ij, icase, ierr ! local integer + ! + ! weights corresponding to corner points of a T cell quadrant + REAL(wp) :: zi, zj ! local real + ! + ! 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 + !!---------------------------------------------------------------------- + ! + 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) + + ! find position in this processor. Prevent near edge problems (see #1389) + ! + ierr = 0 + IF ( ii < mig( 1 ) ) THEN ; ii = 1 ; ierr = ierr + 1 + ELSEIF( ii > mig(jpi) ) THEN ; ii = jpi ; ierr = ierr + 1 + ELSE ; ii = mi1(ii) + ENDIF + IF ( ij < mjg( 1 ) ) THEN ; ij = 1 ; ierr = ierr + 1 + ELSEIF( ij > mjg(jpj) ) THEN ; ij = jpj ; ierr = ierr + 1 + ELSE ; ij = mj1(ij) + ENDIF + ! + IF( ii == jpi ) THEN ; ii = ii-1 ; ierr = ierr + 1 ; END IF + IF( ij == jpj ) THEN ; ij = ij-1 ; ierr = ierr + 1 ; END IF + ! + IF ( ierr > 0 ) CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error)') + ! + 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_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%uo, pt%vo, 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 :: 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','uo,vo','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 + + !!====================================================================== +END MODULE icbutl diff --git a/NEMO_4.0.4_surge/src/OCE/IOM/in_out_manager.F90 b/NEMO_4.0.4_surge/src/OCE/IOM/in_out_manager.F90 new file mode 100644 index 0000000..e3ee750 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/IOM/in_out_manager.F90 @@ -0,0 +1,183 @@ +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) + LOGICAL :: ln_rst_eos !: check equation of state used for the restart is consistent with model + 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_rstdate !: T=> stamp output restart files with date instead of timestep + LOGICAL :: ln_cfmeta !: output additional data to netCDF files required for compliance with the CF metadata standard + LOGICAL :: ln_clobber !: clobber (overwrite) an existing file + INTEGER :: nn_chunksz !: chunksize (bytes) for NetCDF file (works only with iom_nf90 routines) + LOGICAL :: ln_xios_read !: use xios to read single file restart + INTEGER :: nn_wxios !: write resart using xios 0 - no, 1 - single, 2 - multiple file output + INTEGER :: nn_no !: Assimilation cycle + +#if defined key_netcdf4 + !!---------------------------------------------------------------------- + !! namnc4 namelist parameters (key_netcdf4) + !!---------------------------------------------------------------------- + ! The following four values determine the partitioning of the output fields + ! into netcdf4 chunks. They are unrelated to the nn_chunk_sz setting which is + ! for runtime optimisation. The individual netcdf4 chunks can be optionally + ! gzipped (recommended) leading to significant reductions in I/O volumes + ! !!!** variables only used with iom_nf90 routines and key_netcdf4 ** + INTEGER :: nn_nchunks_i !: number of chunks required in the i-dimension + INTEGER :: nn_nchunks_j !: number of chunks required in the j-dimension + INTEGER :: nn_nchunks_k !: number of chunks required in the k-dimension + INTEGER :: nn_nchunks_t !: number of chunks required in the t-dimension + LOGICAL :: ln_nc4zip !: netcdf4 usage: (T) chunk and compress output using the HDF5 sublayers of netcdf4 + ! ! (F) ignore chunking request and use the netcdf4 library + ! ! to produce netcdf3-compatible files +#endif + +!$AGRIF_DO_NOT_TREAT + TYPE(snc4_ctl) :: snc4set !: netcdf4 chunking control structure (always needed for decision making) +!$AGRIF_END_DO_NOT_TREAT + + + !! conversion of DOCTOR norm namelist name into model name + !! (this should disappear in a near futur) + + CHARACTER(lc) :: cexper !: experiment name used for output filename + INTEGER :: nrstdt !: control of the time step (0, 1 or 2) + INTEGER :: nit000 !: index of the first time step + INTEGER :: nitend !: index of the last time step + INTEGER :: ndate0 !: initial calendar date aammjj + INTEGER :: nleapy !: Leap year calendar flag (0/1 or 30) + INTEGER :: ninist !: initial state output flag (0/1) + + !!---------------------------------------------------------------------- + !! was in restart but moved here because of the OFF line... better solution should be found... + !!---------------------------------------------------------------------- + INTEGER :: nitrst !: time step at which restart file should be written + LOGICAL :: lrst_oce !: logical to control the oce restart write + LOGICAL :: lrst_ice !: logical to control the ice restart write + INTEGER :: numror = 0 !: logical unit for ocean restart (read). Init to 0 is needed for SAS (in daymod.F90) + INTEGER :: numrir !: logical unit for ice restart (read) + INTEGER :: numrow !: logical unit for ocean restart (write) + INTEGER :: numriw !: logical unit for ice restart (write) + INTEGER :: nrst_lst !: number of restart to output next + + !!---------------------------------------------------------------------- + !! output monitoring + !!---------------------------------------------------------------------- + LOGICAL :: ln_ctl !: run control for debugging + TYPE :: sn_ctl !: optional use structure for finer control over output selection + LOGICAL :: l_config = .FALSE. !: activate/deactivate finer control + ! Note if l_config is True then ln_ctl is ignored. + ! Otherwise setting ln_ctl True is equivalent to setting + ! all the following logicals in this structure True + 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_mppout = .FALSE. !: Produce/do not produce mpp.output_XXXX files (T/F) + LOGICAL :: l_mpptop = .FALSE. !: Produce/do not produce mpp.top.output_XXXX files (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_print !: level of print (0 no print) + 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 + ! + INTEGER :: nprint, nictls, nictle, njctls, njctle, isplt, jsplt !: OLD namelist names + + INTEGER :: ijsplt = 1 !: nb of local domain = nb of processors + + !!---------------------------------------------------------------------- + !! 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 :: numnam_ref = -1 !: logical unit for reference namelist + INTEGER :: numnam_cfg = -1 !: logical unit for configuration specific namelist + INTEGER :: numond = -1 !: logical unit for Output Namelist Dynamics + INTEGER :: numnam_ice_ref = -1 !: logical unit for ice reference namelist + INTEGER :: numnam_ice_cfg = -1 !: logical unit for ice reference namelist + 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 voulume 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 + + !!---------------------------------------------------------------------- + !! 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. ln_ctl + LOGICAL :: lsp_area = .TRUE. !: to make a control print over a specific area + CHARACTER(lc) :: cxios_context !: context name used in xios + CHARACTER(lc) :: crxios_context !: context name used in xios to read restart + CHARACTER(lc) :: cwxios_context !: context name used in xios to write restart file + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!===================================================================== +END MODULE in_out_manager diff --git a/NEMO_4.0.4_surge/src/OCE/IOM/iom.F90 b/NEMO_4.0.4_surge/src/OCE/IOM/iom.F90 new file mode 100644 index 0000000..bfb3a9a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/IOM/iom.F90 @@ -0,0 +1,2472 @@ +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 c1d ! 1D vertical configuration + 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 +#if defined key_iomput + USE sbc_oce , ONLY : nn_fsbc ! ocean space and time domain + USE trc_oce , ONLY : nn_dttrc ! !: frequency of step on passive tracers + USE icb_oce , ONLY : nclasses, class_num ! !: iceberg classes +#if defined key_si3 + USE ice , ONLY : jpl +#endif + USE domngb ! ocean space and time domain + USE phycst ! physical constants + USE dianam ! build name of file + USE xios +# endif + USE ioipsl, ONLY : ju2ymds ! for calendar + USE crs ! Grid coarsening +#if defined key_top + USE trc, ONLY : profsed +#endif + USE lib_fortran + USE diurnal_bulk, ONLY : ln_diurnal_only, ln_diurnal + + IMPLICIT NONE + PUBLIC ! must be public to be able to access iom_def through iom + +#if defined key_iomput + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .TRUE. !: iom_put flag +#else + LOGICAL, PUBLIC, PARAMETER :: lk_iomput = .FALSE. !: iom_put flag +#endif + PUBLIC iom_init, 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_miss_val + + PRIVATE iom_rp0d, iom_rp1d, iom_rp2d, iom_rp3d + PRIVATE iom_g0d, iom_g1d, iom_g2d, iom_g3d, iom_get_123d + PRIVATE iom_p1d, iom_p2d, iom_p3d, iom_p4d +#if defined key_iomput + 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_update_file_name, iom_sdate + PRIVATE iom_set_rst_context, iom_set_rstw_active, iom_set_rstr_active +# endif + PUBLIC iom_set_rstw_var_active, iom_set_rstw_core, iom_set_rst_vars + + INTERFACE iom_get + MODULE PROCEDURE iom_g0d, iom_g1d, iom_g2d, iom_g3d + 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, iom_rp1d, iom_rp2d, iom_rp3d + END INTERFACE + INTERFACE iom_put + MODULE PROCEDURE iom_p0d, iom_p1d, iom_p2d, iom_p3d, iom_p4d + END INTERFACE iom_put + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_init( cdname, fname, ld_tmppatch ) + !!---------------------------------------------------------------------- + !! *** ROUTINE *** + !! + !! ** Purpose : + !! + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname + CHARACTER(len=*), OPTIONAL, INTENT(in) :: fname + LOGICAL , OPTIONAL, INTENT(in) :: ld_tmppatch +#if defined key_iomput + ! + 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 + ! + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zt_bnds, zw_bnds + LOGICAL :: ll_tmppatch = .TRUE. !: seb: patch before we remove periodicity + INTEGER :: nldi_save, nlei_save !: and close boundaries in output files + INTEGER :: nldj_save, nlej_save !: + !!---------------------------------------------------------------------- + ! + ! seb: patch before we remove periodicity and close boundaries in output files + IF( PRESENT(ld_tmppatch) ) THEN ; ll_tmppatch = ld_tmppatch + ELSE ; ll_tmppatch = .TRUE. + ENDIF + IF ( ll_tmppatch ) THEN + nldi_save = nldi ; nlei_save = nlei + nldj_save = nldj ; nlej_save = nlej + IF( nimpp == 1 ) nldi = 1 + IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi + IF( njmpp == 1 ) nldj = 1 + IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj + ENDIF + ! + 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 ) + llrst_context = (TRIM(cdname) == TRIM(crxios_context) .OR. TRIM(cdname) == TRIM(cwxios_context)) + + ! 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,00,00,00), & + & start_date = xios_date(nyear,nmonth,nday,nhour,nminute,0) ) + CASE ( 0) ; CALL xios_define_calendar( TYPE = "NoLeap" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), & + & start_date = xios_date(nyear,nmonth,nday,nhour,nminute,0) ) + CASE (30) ; CALL xios_define_calendar( TYPE = "D360" , time_origin = xios_date(irefyear,irefmonth,irefday,00,00,00), & + & start_date = xios_date(nyear,nmonth,nday,nhour,nminute,0) ) + END SELECT + + ! horizontal grid definition + IF(.NOT.llrst_context) CALL set_scalar + ! + IF( TRIM(cdname) == TRIM(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_znl( gphit ) + ! + IF( ln_cfmeta ) THEN ! Add additional grid metadata + CALL iom_set_domain_attr("grid_T", area = e1e2t(nldi:nlei, nldj:nlej)) + CALL iom_set_domain_attr("grid_U", area = e1e2u(nldi:nlei, nldj:nlej)) + CALL iom_set_domain_attr("grid_V", area = e1e2v(nldi:nlei, nldj:nlej)) + CALL iom_set_domain_attr("grid_W", area = e1e2t(nldi:nlei, nldj:nlej)) + 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 ) + 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 = e1e2t_crs(nldi:nlei, nldj:nlej)) + CALL iom_set_domain_attr("grid_U", area = e1u_crs(nldi:nlei, nldj:nlej) * e2u_crs(nldi:nlei, nldj:nlej)) + CALL iom_set_domain_attr("grid_V", area = e1v_crs(nldi:nlei, nldj:nlej) * e2v_crs(nldi:nlei, nldj:nlej)) + CALL iom_set_domain_attr("grid_W", area = e1e2t_crs(nldi:nlei, nldj:nlej)) + 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 ) + + ! 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( "nfloat", (/ (REAL(ji,wp), ji=1,jpnfl) /) ) +# if defined key_si3 + CALL iom_set_axis_attr( "ncatice", (/ (REAL(ji,wp), ji=1,jpl) /) ) + ! SIMIP diagnostics (4 main arctic straits) + CALL iom_set_axis_attr( "nstrait", (/ (REAL(ji,wp), ji=1,4) /) ) +# endif +#if defined key_top + IF( ALLOCATED(profsed) ) CALL iom_set_axis_attr( "profsed", paxis = profsed ) +#endif + CALL iom_set_axis_attr( "icbcla", class_num ) + CALL iom_set_axis_attr( "iax_20C", (/ REAL(20,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_26C", (/ REAL(26,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "iax_28C", (/ REAL(28,wp) /) ) ! strange syntaxe and idea... + CALL iom_set_axis_attr( "basin" , (/ (REAL(ji,wp), ji=1,5) /) ) + ENDIF + ! + ! automatic definitions of some of the xml attributs + IF( TRIM(cdname) == TRIM(crxios_context) ) THEN +!set names of the fields in restart file IF using XIOS to read data + CALL iom_set_rst_context(.TRUE.) + CALL iom_set_rst_vars(rst_rfields) +!set which fields are to be read from restart file + CALL iom_set_rstr_active() + ELSE IF( TRIM(cdname) == TRIM(cwxios_context) ) THEN +!set names of the fields in restart file IF using XIOS to write data + CALL iom_set_rst_context(.FALSE.) + CALL iom_set_rst_vars(rst_wfields) +!set which fields are to be written to a restart file + CALL iom_set_rstw_active(fname) + ELSE + CALL set_xmlatt + ENDIF + ! + ! end file definition + dtime%second = rdt + CALL xios_set_timestep( dtime ) + CALL xios_close_context_definition() + CALL xios_update_calendar( 0 ) + ! + DEALLOCATE( zt_bnds, zw_bnds ) + ! + IF ( ll_tmppatch ) THEN + nldi = nldi_save ; nlei = nlei_save + nldj = nldj_save ; nlej = nlej_save + ENDIF +#endif + ! + END SUBROUTINE iom_init + + SUBROUTINE iom_set_rstw_var_active(field) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstw_var_active *** + !! + !! ** Purpose : enable variable in restart file when writing with XIOS + !!--------------------------------------------------------------------- + CHARACTER(len = *), INTENT(IN) :: field + INTEGER :: i + LOGICAL :: llis_set + CHARACTER(LEN=256) :: clinfo ! info character + +#if defined key_iomput + llis_set = .FALSE. + + DO i = 1, max_rst_fields + IF(TRIM(rst_wfields(i)%vname) == field) THEN + rst_wfields(i)%active = .TRUE. + llis_set = .TRUE. + EXIT + ENDIF + ENDDO +!Warn if variable is not in defined in rst_wfields + IF(.NOT.llis_set) THEN + WRITE(ctmp1,*) 'iom_set_rstw_var_active: variable ', field ,' is available for writing but not defined' + CALL ctl_stop( 'iom_set_rstw_var_active:', ctmp1 ) + ENDIF +#else + clinfo = 'iom_set_rstw_var_active: key_iomput is needed to use XIOS restart read/write functionality' + CALL ctl_stop('STOP', TRIM(clinfo)) +#endif + + END SUBROUTINE iom_set_rstw_var_active + + SUBROUTINE iom_set_rstr_active() + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstr_active *** + !! + !! ** Purpose : define file name in XIOS context for reading restart file, + !! enable variables present in restart file for reading with XIOS + !!--------------------------------------------------------------------- + +!sets enabled = .TRUE. for each field in restart file + CHARACTER(len=256) :: rst_file + +#if defined key_iomput + TYPE(xios_field) :: field_hdl + TYPE(xios_file) :: file_hdl + TYPE(xios_filegroup) :: filegroup_hdl + INTEGER :: i + CHARACTER(lc) :: clpath + + clpath = TRIM(cn_ocerst_indir) + IF( clpath(LEN_TRIM(clpath):) /= '/' ) clpath = TRIM(clpath) // '/' + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + rst_file = TRIM(clpath)//TRIM(cn_ocerst_in) + ELSE + rst_file = TRIM(clpath)//TRIM(Agrif_CFixed())//'_'//TRIM(cn_ocerst_in) + ENDIF +!set name of the restart file and enable available fields + if(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS) to: ',rst_file + CALL xios_get_handle("file_definition", filegroup_hdl ) + CALL xios_add_child(filegroup_hdl, file_hdl, 'rrestart') + CALL xios_set_file_attr( "rrestart", name=trim(rst_file), type="one_file", & + par_access="collective", enabled=.TRUE., mode="read", & + output_freq=xios_timestep) +!define variables for restart context + DO i = 1, max_rst_fields + IF( TRIM(rst_rfields(i)%vname) /= "NO_NAME") THEN + IF( iom_varid( numror, TRIM(rst_rfields(i)%vname), ldstop = .FALSE. ) > 0 ) THEN + CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_rfields(i)%vname)) + SELECT CASE (TRIM(rst_rfields(i)%grid)) + CASE ("grid_N_3D") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & + domain_ref="grid_N", axis_ref="nav_lev", operation = "instant") + CASE ("grid_N") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & + domain_ref="grid_N", operation = "instant") + CASE ("grid_vector") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & + axis_ref="nav_lev", operation = "instant") + CASE ("grid_scalar") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_rfields(i)%vname), & + scalar_ref = "grid_scalar", operation = "instant") + END SELECT + IF(lwp) WRITE(numout,*) 'XIOS read: ', TRIM(rst_rfields(i)%vname), ' enabled in ', TRIM(rst_file) + ENDIF + ENDIF + END DO +#endif + END SUBROUTINE iom_set_rstr_active + + SUBROUTINE iom_set_rstw_core(cdmdl) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rstw_core *** + !! + !! ** Purpose : set variables which are always in restart file + !!--------------------------------------------------------------------- + CHARACTER (len=*), INTENT (IN) :: cdmdl ! model OPA or SAS + CHARACTER(LEN=256) :: clinfo ! info character +#if defined key_iomput + IF(cdmdl == "OPA") THEN +!from restart.F90 + CALL iom_set_rstw_var_active("rdt") + CALL iom_set_rstw_var_active("neos") + + IF ( .NOT. ln_diurnal_only ) THEN + CALL iom_set_rstw_var_active('ub' ) + CALL iom_set_rstw_var_active('vb' ) + CALL iom_set_rstw_var_active('tb' ) + CALL iom_set_rstw_var_active('sb' ) + CALL iom_set_rstw_var_active('sshb') + ! + CALL iom_set_rstw_var_active('un' ) + CALL iom_set_rstw_var_active('vn' ) + CALL iom_set_rstw_var_active('tn' ) + CALL iom_set_rstw_var_active('sn' ) + CALL iom_set_rstw_var_active('sshn') + CALL iom_set_rstw_var_active('rhop') + ! extra variable needed for the ice sheet coupling + IF ( ln_iscpl ) THEN + CALL iom_set_rstw_var_active('tmask') + CALL iom_set_rstw_var_active('umask') + CALL iom_set_rstw_var_active('vmask') + CALL iom_set_rstw_var_active('smask') + CALL iom_set_rstw_var_active('e3t_n') + CALL iom_set_rstw_var_active('e3u_n') + CALL iom_set_rstw_var_active('e3v_n') + CALL iom_set_rstw_var_active('gdepw_n') + END IF + ENDIF + IF(ln_diurnal) CALL iom_set_rstw_var_active('Dsst') +!from trasbc.F90 + CALL iom_set_rstw_var_active('sbc_hc_b') + CALL iom_set_rstw_var_active('sbc_sc_b') + ENDIF +#else + clinfo = 'iom_set_rstw_core: key_iomput is needed to use XIOS restart read/write functionality' + CALL ctl_stop('STOP', TRIM(clinfo)) +#endif + END SUBROUTINE iom_set_rstw_core + + SUBROUTINE iom_set_rst_vars(fields) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_set_rst_vars *** + !! + !! ** Purpose : Fill array fields with the information about all + !! possible variables and corresponding grids definition + !! for reading/writing restart with XIOS + !!--------------------------------------------------------------------- + TYPE(RST_FIELD), INTENT(INOUT) :: fields(max_rst_fields) + INTEGER :: i + + i = 0 + i = i + 1; fields(i)%vname="rdt"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="neos"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="un"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="ub"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="vn"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="vb"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="tn"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="tb"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="sn"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="sb"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="sshn"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sshb"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="rhop"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="kt"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="ndastp"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="adatrj"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="utau_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="vtau_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="qns_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="emp_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sfx_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="en" ; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="avt_k"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="avm_k"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="dissl"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="sbc_hc_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sbc_sc_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="qsr_hc_b"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="fraqsr_1lev"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="greenland_icesheet_mass" + fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="greenland_icesheet_timelapsed" + fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="greenland_icesheet_mass_roc" + fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="antarctica_icesheet_mass" + fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="antarctica_icesheet_timelapsed" + fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="antarctica_icesheet_mass_roc" + fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="frc_v"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="frc_t"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="frc_s"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="frc_wn_t"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="frc_wn_s"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="ssh_ini"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="e3t_ini"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="hc_loc_ini"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="sc_loc_ini"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="ssh_hc_loc_ini"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ssh_sc_loc_ini"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="tilde_e3t_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="tilde_e3t_n"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="hdiv_lf"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ub2_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="vb2_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sshbb_e"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ubb_e"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="vbb_e"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sshb_e"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ub_e"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="vb_e"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="fwf_isf_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="isf_sc_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="isf_hc_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ssh_ibb"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="rnf_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="rnf_hc_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="rnf_sc_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="nn_fsbc"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="ssu_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ssv_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sst_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="sss_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ssh_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="e3t_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="frq_m"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="avmb"; fields(i)%grid="grid_vector" + i = i + 1; fields(i)%vname="avtb"; fields(i)%grid="grid_vector" + i = i + 1; fields(i)%vname="ub2_i_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="vb2_i_b"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="ntime"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="Dsst"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="tmask"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="umask"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="vmask"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="smask"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="gdepw_n"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="e3t_n"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="e3u_n"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="e3v_n"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="surf_ini"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="e3t_b"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="hmxl_n"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="un_bf"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="vn_bf"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="hbl"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="hbli"; fields(i)%grid="grid_N" + i = i + 1; fields(i)%vname="wn"; fields(i)%grid="grid_N_3D" + i = i + 1; fields(i)%vname="a_fwb_b"; fields(i)%grid="grid_scalar" + i = i + 1; fields(i)%vname="a_fwb"; fields(i)%grid="grid_scalar" + + IF( i-1 > max_rst_fields) THEN + WRITE(ctmp1,*) 'E R R O R : iom_set_rst_vars SIZE of RST_FIELD array is too small' + CALL ctl_stop( 'iom_set_rst_vars:', ctmp1 ) + ENDIF + END SUBROUTINE iom_set_rst_vars + + + SUBROUTINE iom_set_rstw_active(cdrst_file) + !!--------------------------------------------------------------------- + !! *** 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=*) :: cdrst_file +#if defined key_iomput + TYPE(xios_field) :: field_hdl + TYPE(xios_file) :: file_hdl + TYPE(xios_filegroup) :: filegroup_hdl + INTEGER :: i + CHARACTER(lc) :: clpath + +!set name of the restart file and enable available fields + IF(lwp) WRITE(numout,*) 'Setting restart filename (for XIOS write) to: ',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)) +!define fields for restart context + DO i = 1, max_rst_fields + IF( rst_wfields(i)%active ) THEN + CALL xios_add_child(file_hdl, field_hdl, TRIM(rst_wfields(i)%vname)) + SELECT CASE (TRIM(rst_wfields(i)%grid)) + CASE ("grid_N_3D") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & + domain_ref="grid_N", axis_ref="nav_lev", prec = 8, operation = "instant") + CASE ("grid_N") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & + domain_ref="grid_N", prec = 8, operation = "instant") + CASE ("grid_vector") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & + axis_ref="nav_lev", prec = 8, operation = "instant") + CASE ("grid_scalar") + CALL xios_set_attr (field_hdl, enabled = .TRUE., name = TRIM(rst_wfields(i)%vname), & + scalar_ref = "grid_scalar", prec = 8, operation = "instant") + END SELECT + ENDIF + END DO +#endif + END SUBROUTINE iom_set_rstw_active + + 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 +!ld_rstr is true for restart context. There is no need to define grid for +!restart read, because it's read from file +#if defined key_iomput + 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_get_handle("scalar_definition", scalargroup_hdl) + CALL xios_add_child(scalargroup_hdl, scalar_hdl, "grid_scalar") +#endif + END SUBROUTINE iom_set_rst_context + + SUBROUTINE iom_swap( cdname ) + !!--------------------------------------------------------------------- + !! *** SUBROUTINE iom_swap *** + !! + !! ** Purpose : swap context between different agrif grid for xmlio_server + !!--------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in) :: cdname +#if defined key_iomput + 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) +#endif + ! + END SUBROUTINE iom_swap + + + SUBROUTINE iom_open( cdname, kiomid, ldwrt, kdom, ldstop, ldiof, kdlev ) + !!--------------------------------------------------------------------- + !! *** 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.) + INTEGER , INTENT(in ), OPTIONAL :: kdom ! Type of domain to be written (default = jpdom_local_noovlap) + 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=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 :: llnoov ! local definition to read overlap + 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 :: idom ! type of domain + INTEGER :: istop ! + INTEGER, DIMENSION(2,5) :: idompar ! domain parameters: + ! 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 + ! do we read the overlap + ! ugly patch SM+JMM+RB to overwrite global definition in some cases + llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif + ! 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 +!FUS iln = INDEX(clname,'/') + iln = INDEX(clname,'/',BACK=.true.) ! FUS: to insert the nest index at the right location within the string, the last / has to be found (search from the right to left) + 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 + IF( llwrt ) THEN + ! check the domain definition +! JMM + SM: ugly patch before getting the new version of lib_mpp) +! idom = jpdom_local_noovlap ! default definition + IF( llnoov ) THEN ; idom = jpdom_local_noovlap ! default definition + ELSE ; idom = jpdom_local_full ! default definition + ENDIF + IF( PRESENT(kdom) ) idom = kdom + ! create the domain informations + ! ============= + SELECT CASE (idom) + CASE (jpdom_local_full) + idompar(:,1) = (/ jpi , jpj /) + idompar(:,2) = (/ nimpp , njmpp /) + idompar(:,3) = (/ nimpp + jpi - 1 , njmpp + jpj - 1 /) + idompar(:,4) = (/ nldi - 1 , nldj - 1 /) + idompar(:,5) = (/ jpi - nlei , jpj - nlej /) + CASE (jpdom_local_noextra) + idompar(:,1) = (/ nlci , nlcj /) + idompar(:,2) = (/ nimpp , njmpp /) + idompar(:,3) = (/ nimpp + nlci - 1, njmpp + nlcj - 1 /) + idompar(:,4) = (/ nldi - 1 , nldj - 1 /) + idompar(:,5) = (/ nlci - nlei , nlcj - nlej /) + CASE (jpdom_local_noovlap) + idompar(:,1) = (/ nlei - nldi + 1, nlej - nldj + 1 /) + idompar(:,2) = (/ nimpp + nldi - 1, njmpp + nldj - 1 /) + idompar(:,3) = (/ nimpp + nlei - 1, njmpp + nlej - 1 /) + idompar(:,4) = (/ 0 , 0 /) + idompar(:,5) = (/ 0 , 0 /) + CASE DEFAULT + CALL ctl_stop( TRIM(clinfo), 'wrong value of kdom, only jpdom_local* cases are accepted' ) + END SELECT + 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, idompar, kdlev = kdlev ) + 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( kiomid, cdvar, pvar, ktime, ldxios ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdvar ! Name of the variable + REAL(wp) , INTENT( out) :: pvar ! read field + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use xios to read restart + ! + 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 ! + LOGICAL :: llxios + ! + llxios = .FALSE. + IF( PRESENT(ldxios) ) llxios = ldxios + + IF(.NOT.llxios) THEN ! read data using default library + itime = 1 + IF( PRESENT(ktime) ) itime = ktime + ! + clname = iom_file(kiomid)%name + clinfo = ' iom_g0d, file: '//trim(clname)//', var: '//trim(cdvar) + ! + IF( kiomid > 0 ) THEN + idvar = iom_varid( kiomid, cdvar ) + IF( iom_file(kiomid)%nfid > 0 .AND. idvar > 0 ) THEN + idmspc = iom_file ( kiomid )%ndims( idvar ) + IF( iom_file(kiomid)%luld(idvar) ) idmspc = idmspc - 1 + WRITE(cldmspc , fmt='(i1)') idmspc + IF( idmspc > 0 ) CALL ctl_stop( TRIM(clinfo), 'When reading to a 0D array, we do not accept data', & + & 'with 1 or more spatial dimensions: '//cldmspc//' were found.' , & + & 'Use ncwa -a to suppress the unnecessary dimensions' ) + CALL iom_nf90_get( kiomid, idvar, pvar, itime ) + ENDIF + ENDIF + ELSE +#if defined key_iomput + IF(lwp) WRITE(numout,*) 'XIOS RST READ (0D): ', trim(cdvar) + CALL iom_swap( TRIM(crxios_context) ) + CALL xios_recv_field( trim(cdvar), pvar) + CALL iom_swap( TRIM(cxios_context) ) +#else + WRITE(ctmp1,*) 'Can not use XIOS in iom_g0d, file: '//trim(clname)//', var:'//trim(cdvar) + CALL ctl_stop( 'iom_g0d', ctmp1 ) +#endif + ENDIF + END SUBROUTINE iom_g0d + + SUBROUTINE iom_g1d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, ldxios ) + 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(wp) , 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 + LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS + ! + 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, & + & ldxios=ldxios ) + ENDIF + END SUBROUTINE iom_g1d + + SUBROUTINE iom_g2d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios) + 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(wp) , INTENT( out), DIMENSION(:,:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + 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 + LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to + ! look for and use a file attribute + ! called open_ocean_jstart to set the start + ! value for the 2nd dimension (netcdf only) + LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r2d=pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount, & + & lrowattr=lrowattr, ldxios=ldxios) + ENDIF + END SUBROUTINE iom_g2d + + SUBROUTINE iom_g3d( kiomid, kdom, cdvar, pvar, ktime, kstart, kcount, lrowattr, ldxios ) + 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(wp) , INTENT( out), DIMENSION(:,:,:) :: pvar ! read field + INTEGER , INTENT(in ) , OPTIONAL :: ktime ! record number + 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 + LOGICAL , INTENT(in ) , OPTIONAL :: lrowattr ! logical flag telling iom_get to + ! look for and use a file attribute + ! called open_ocean_jstart to set the start + ! value for the 2nd dimension (netcdf only) + LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! read data using XIOS + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_get_123d( kiomid, kdom , cdvar , pv_r3d=pvar, & + & ktime=ktime, kstart=kstart, kcount=kcount, & + & lrowattr=lrowattr, ldxios=ldxios ) + ENDIF + END SUBROUTINE iom_g3d + !!---------------------------------------------------------------------- + + SUBROUTINE iom_get_123d( kiomid, kdom , cdvar , & + & pv_r1d, pv_r2d, pv_r3d, & + & ktime , kstart, kcount, & + & lrowattr, ldxios ) + !!----------------------------------------------------------------------- + !! *** 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(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(wp), DIMENSION(:,:,:) , INTENT( out), OPTIONAL :: pv_r3d ! read field (3D case) + INTEGER , INTENT(in ), OPTIONAL :: ktime ! record number + 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 , INTENT(in ), OPTIONAL :: lrowattr ! logical flag telling iom_get to + ! look for and use a file attribute + ! called open_ocean_jstart to set the start + ! value for the 2nd dimension (netcdf only) + LOGICAL , INTENT(in ), OPTIONAL :: ldxios ! use XIOS to read restart + ! + LOGICAL :: llxios ! local definition for XIOS read + LOGICAL :: llnoov ! local definition to read overlap + LOGICAL :: luse_jattr ! local definition to read open_ocean_jstart file attribute + INTEGER :: jstartrow ! start point for 2nd dimension optionally set by file attribute + 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(wp) :: zscf, zofs ! sacle_factor and add_offset + INTEGER :: itmp ! temporary integer + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: clname ! file name + CHARACTER(LEN=1) :: clrankpv, cldmspc ! + LOGICAL :: ll_depth_spec ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension. + INTEGER :: inlev ! number of levels for 3D data + REAL(wp) :: gma, gmi + !--------------------------------------------------------------------- + ! + inlev = -1 + IF( PRESENT(pv_r3d) ) inlev = SIZE(pv_r3d, 3) + ! + llxios = .FALSE. + if(PRESENT(ldxios)) llxios = ldxios + idvar = iom_varid( kiomid, cdvar ) + idom = kdom + ! + IF(.NOT.llxios) THEN + clname = iom_file(kiomid)%name ! esier to read + clinfo = ' iom_get_123d, file: '//trim(clname)//', var: '//trim(cdvar) + ! local definition of the domain ? + ! do we read the overlap + ! ugly patch SM+JMM+RB to overwrite global definition in some cases + llnoov = (jpni * jpnj ) == jpnij .AND. .NOT. lk_agrif + ! 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_autoglo_xy ) & + & CALL ctl_stop(trim(clinfo), 'kstart present needs kdom = jpdom_unknown or kdom = jpdom_autoglo_xy') + + luse_jattr = .false. + IF( PRESENT(lrowattr) ) THEN + IF( lrowattr .AND. idom /= jpdom_data ) CALL ctl_stop(trim(clinfo), 'lrowattr present and true needs kdom = jpdom_data') + IF( lrowattr .AND. idom == jpdom_data ) luse_jattr = .true. + ENDIF + + ! Search for the variable in the data base (eventually actualize data) + istop = nstop + ! + IF( idvar > 0 ) THEN + ! to write iom_file(kiomid)%dimsz in a shorter way ! + idimsz(:) = iom_file(kiomid)%dimsz(:, idvar) + 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...') + ! + ! update idom definition... + ! Identify the domain in case of jpdom_auto(glo/dta) definition + IF( idom == jpdom_autoglo_xy ) THEN + ll_depth_spec = .TRUE. + idom = jpdom_autoglo + ELSE + ll_depth_spec = .FALSE. + ENDIF + IF( idom == jpdom_autoglo .OR. idom == jpdom_autodta ) THEN + IF( idom == jpdom_autoglo ) THEN ; idom = jpdom_global + ELSE ; idom = jpdom_data + ENDIF + 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 + ! Identify the domain in case of jpdom_local definition + IF( idom == jpdom_local ) THEN + IF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN ; idom = jpdom_local_full + ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN ; idom = jpdom_local_noextra + ELSEIF( idimsz(1) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN ; idom = jpdom_local_noovlap + ELSE ; CALL ctl_stop( trim(clinfo), 'impossible to identify the local domain' ) + 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 + CALL ctl_stop( TRIM(clinfo), 'The file has only '//cldmspc//' spatial dimension', & + & 'it is impossible to read a '//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 + IF( PRESENT(pv_r2d) .AND. itime == 1 .AND. idimsz(3) == 1 .AND. idmspc == 3 ) THEN + CALL ctl_warn( trim(clinfo), '2D array but 3 spatial dimensions for the data...' , & + & '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 + 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 + istart(:) = 1 + istart(idmspc+1) = itime + + IF( PRESENT(kstart) .AND. .NOT. ll_depth_spec ) THEN + istart(1:idmspc) = kstart(1:idmspc) + icnt (1:idmspc) = kcount(1:idmspc) + ELSE + IF(idom == jpdom_unknown ) THEN + icnt(1:idmspc) = idimsz(1:idmspc) + ELSE + IF( .NOT. PRESENT(pv_r1d) ) THEN ! not a 1D array + IF( idom == jpdom_data ) THEN + jstartrow = 1 + IF( luse_jattr ) THEN + CALL iom_getatt(kiomid, 'open_ocean_jstart', jstartrow ) ! -999 is returned if the attribute is not found + jstartrow = MAX(1,jstartrow) + ENDIF + istart(1:2) = (/ mig(1), mjg(1) + jstartrow - 1 /) ! icnt(1:2) done below + ELSEIF( idom == jpdom_global ) THEN ; istart(1:2) = (/ nimpp , njmpp /) ! icnt(1:2) done below + ENDIF + ! we do not read the overlap -> we start to read at nldi, nldj +! JMM + SM: ugly patch before getting the new version of lib_mpp) +! IF( idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) + IF( llnoov .AND. idom /= jpdom_local_noovlap ) istart(1:2) = istart(1:2) + (/ nldi - 1, nldj - 1 /) + ! we do not read the overlap and the extra-halos -> from nldi to nlei and from nldj to nlej +! JMM + SM: ugly patch before getting the new version of lib_mpp) +! icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) + IF( llnoov ) THEN ; icnt(1:2) = (/ nlei - nldi + 1, nlej - nldj + 1 /) + ELSE ; icnt(1:2) = (/ nlci , nlcj /) + ENDIF + IF( PRESENT(pv_r3d) ) THEN + IF( idom == jpdom_data ) THEN ; icnt(3) = inlev + ELSEIF( ll_depth_spec .AND. PRESENT(kstart) ) THEN ; istart(3) = kstart(3) ; icnt(3) = kcount(3) + ELSE ; icnt(3) = inlev + ENDIF + ENDIF + 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 +! JMM + SM: ugly patch before getting the new version of lib_mpp) +! ishape(1:2) = SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1 = 'd(nldi:nlei,nldj:nlej)' + IF( llnoov ) THEN ; ishape(1:2)=SHAPE(pv_r2d(nldi:nlei,nldj:nlej )) ; ctmp1='d(nldi:nlei,nldj:nlej)' + ELSE ; ishape(1:2)=SHAPE(pv_r2d(1 :nlci,1 :nlcj )) ; ctmp1='d(1:nlci,1:nlcj)' + ENDIF + ENDIF + IF( irankpv == 3 ) THEN +! JMM + SM: ugly patch before getting the new version of lib_mpp) +! ishape(1:3) = SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1 = 'd(nldi:nlei,nldj:nlej,:)' + IF( llnoov ) THEN ; ishape(1:3)=SHAPE(pv_r3d(nldi:nlei,nldj:nlej,:)) ; ctmp1='d(nldi:nlei,nldj:nlej,:)' + ELSE ; ishape(1:3)=SHAPE(pv_r3d(1 :nlci,1 :nlcj,:)) ; ctmp1='d(1:nlci,1:nlcj,:)' + ENDIF + 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 +! JMM + SM: ugly patch before getting the new version of lib_mpp) +! IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej +! ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) +! ENDIF + IF( llnoov ) THEN + IF( idom /= jpdom_unknown ) THEN ; ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej + ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) + ENDIF + ELSE + IF( idom /= jpdom_unknown ) THEN ; ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj + ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) + ENDIF + 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) + + !--- overlap areas and extra hallows (mpp) + IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown ) THEN + CALL lbc_lnk( 'iom', pv_r2d,'Z', -999., kfillmode = jpfillnothing ) + ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown ) THEN + ! this if could be simplified with the new lbc_lnk that works with any size of the 3rd dimension + IF( icnt(3) == inlev ) THEN + CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing ) + ELSE ! put some arbitrary value (a call to lbc_lnk will be done later...) + DO jj = nlcj+1, jpj ; pv_r3d(1:nlci, jj, :) = pv_r3d(1:nlci, nlej, :) ; END DO + DO ji = nlci+1, jpi ; pv_r3d(ji , : , :) = pv_r3d(nlei , : , :) ; END DO + ENDIF + ENDIF + ! + ELSE + ! return if istop == nstop is false + RETURN + ENDIF + ELSE + ! return if statment idvar > 0 .AND. istop == nstop is false + RETURN + ENDIF + ! + ELSE ! read using XIOS. Only if KEY_IOMPUT is defined +#if defined key_iomput +!would be good to be able to check which context is active and swap only if current is not restart + CALL iom_swap( TRIM(crxios_context) ) + IF( PRESENT(pv_r3d) ) THEN + pv_r3d(:, :, :) = 0. + if(lwp) write(numout,*) 'XIOS RST READ (3D): ',trim(cdvar) + CALL xios_recv_field( trim(cdvar), pv_r3d) + IF(idom /= jpdom_unknown ) then + CALL lbc_lnk( 'iom', pv_r3d,'Z', -999., kfillmode = jpfillnothing) + ENDIF + ELSEIF( PRESENT(pv_r2d) ) THEN + pv_r2d(:, :) = 0. + if(lwp) write(numout,*) 'XIOS RST READ (2D): ', trim(cdvar) + CALL xios_recv_field( trim(cdvar), pv_r2d) + IF(idom /= jpdom_unknown ) THEN + CALL lbc_lnk('iom', pv_r2d,'Z',-999., kfillmode = jpfillnothing) + ENDIF + ELSEIF( PRESENT(pv_r1d) ) THEN + pv_r1d(:) = 0. + if(lwp) write(numout,*) 'XIOS RST READ (1D): ', trim(cdvar) + CALL xios_recv_field( trim(cdvar), pv_r1d) + ENDIF + CALL iom_swap( TRIM(cxios_context) ) +#else + istop = istop + 1 + clinfo = 'Can not use XIOS in iom_get_123d, file: '//trim(clname)//', var:'//trim(cdvar) +#endif + ENDIF +!some final adjustments + ! C1D case : always call lbc_lnk to replicate the central value over the whole 3X3 domain + IF( lk_c1d .AND. PRESENT(pv_r2d) ) CALL lbc_lnk( 'iom', pv_r2d,'Z',1. ) + IF( lk_c1d .AND. PRESENT(pv_r3d) ) CALL lbc_lnk( 'iom', pv_r3d,'Z',1. ) + + !--- 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. ) pv_r1d(:) = pv_r1d(:) * zscf + IF( zofs /= 0. ) pv_r1d(:) = pv_r1d(:) + zofs + ELSEIF( PRESENT(pv_r2d) ) THEN + IF( zscf /= 1.) pv_r2d(:,:) = pv_r2d(:,:) * zscf + IF( zofs /= 0.) pv_r2d(:,:) = pv_r2d(:,:) + zofs + ELSEIF( PRESENT(pv_r3d) ) THEN + IF( zscf /= 1.) pv_r3d(:,:,:) = pv_r3d(:,:,:) * zscf + IF( zofs /= 0.) pv_r3d(:,:,:) = pv_r3d(:,:,:) + zofs + ENDIF + ! + END SUBROUTINE iom_get_123d + + SUBROUTINE iom_get_var( cdname, z2d) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp), DIMENSION(jpi,jpj) :: z2d +#if defined key_iomput + IF( xios_field_is_active( cdname, at_current_timestep_arg = .TRUE. ) ) THEN + z2d(:,:) = 0._wp + CALL xios_recv_field( cdname, z2d) + ENDIF +#else + IF( .FALSE. ) WRITE(numout,*) cdname, z2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_get_var + + + FUNCTION iom_getszuld ( kiomid ) + !!----------------------------------------------------------------------- + !! *** FUNCTION iom_getszuld *** + !! + !! ** Purpose : get the size of the unlimited dimension in a file + !! (return -1 if not found) + !!----------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kiomid ! file Identifier + ! + INTEGER :: iom_getszuld + !!----------------------------------------------------------------------- + iom_getszuld = -1 + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%iduld > 0 ) iom_getszuld = iom_file(kiomid)%lenuld + ENDIF + END FUNCTION iom_getszuld + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_chkatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_chkatt( kiomid, cdatt, llok, ksize, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*), INTENT(in ) :: cdatt ! Name of the attribute + LOGICAL , INTENT( out) :: llok ! Error code + INTEGER , INTENT( out), OPTIONAL :: ksize ! Size of the attribute array + CHARACTER(len=*), INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_chkatt( kiomid, cdatt, llok, ksize=ksize, cdvar=cdvar ) + ENDIF + ! + END SUBROUTINE iom_chkatt + + !!---------------------------------------------------------------------- + !! INTERFACE iom_getatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_g0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT( out) :: katt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_iatt + + SUBROUTINE iom_g1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT( out) :: katt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_iatt + + SUBROUTINE iom_g0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT( out) :: patt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_ratt + + SUBROUTINE iom_g1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT( out) :: patt1d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g1d_ratt + + SUBROUTINE iom_g0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT( out) :: cdatt0d ! read field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_getatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_g0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_putatt + !!---------------------------------------------------------------------- + SUBROUTINE iom_p0d_iatt( kiomid, cdatt, katt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER , INTENT(in ) :: katt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt0d = katt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_iatt + + SUBROUTINE iom_p1d_iatt( kiomid, cdatt, katt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + INTEGER, DIMENSION(:) , INTENT(in ) :: katt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, katt1d = katt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_iatt + + SUBROUTINE iom_p0d_ratt( kiomid, cdatt, patt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp) , INTENT(in ) :: patt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt0d = patt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_ratt + + SUBROUTINE iom_p1d_ratt( kiomid, cdatt, patt1d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + REAL(wp), DIMENSION(:), INTENT(in ) :: patt1d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, patt1d = patt1d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p1d_ratt + + SUBROUTINE iom_p0d_catt( kiomid, cdatt, cdatt0d, cdvar ) + INTEGER , INTENT(in ) :: kiomid ! Identifier of the file + CHARACTER(len=*) , INTENT(in ) :: cdatt ! Name of the attribute + CHARACTER(len=*) , INTENT(in ) :: cdatt0d ! written field + CHARACTER(len=*) , INTENT(in ), OPTIONAL :: cdvar ! Name of the variable + ! + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) CALL iom_nf90_putatt( kiomid, cdatt, cdatt0d = cdatt0d, cdvar=cdvar ) + ENDIF + END SUBROUTINE iom_p0d_catt + + + !!---------------------------------------------------------------------- + !! INTERFACE iom_rstput + !!---------------------------------------------------------------------- + SUBROUTINE iom_rp0d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) + 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(wp) , INTENT(in) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + LOGICAL, OPTIONAL :: ldxios ! xios write flag + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + + llx = .FALSE. + IF(PRESENT(ldxios)) llx = ldxios + IF( llx ) THEN +#ifdef key_iomput + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 0D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r0d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp0d + + SUBROUTINE iom_rp1d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) + 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(wp) , INTENT(in), DIMENSION( :) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + LOGICAL, OPTIONAL :: ldxios ! xios write flag + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + + llx = .FALSE. + IF(PRESENT(ldxios)) llx = ldxios + IF( llx ) THEN +#ifdef key_iomput + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 1D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r1d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp1d + + SUBROUTINE iom_rp2d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) + 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(wp) , INTENT(in), DIMENSION(:, : ) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + LOGICAL, OPTIONAL :: ldxios ! xios write flag + LOGICAL :: llx + INTEGER :: ivid ! variable id + + llx = .FALSE. + IF(PRESENT(ldxios)) llx = ldxios + IF( llx ) THEN +#ifdef key_iomput + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 2D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r2d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp2d + + SUBROUTINE iom_rp3d( kt, kwrite, kiomid, cdvar, pvar, ktype, ldxios ) + 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(wp) , INTENT(in), DIMENSION(:,:,:) :: pvar ! written field + INTEGER , INTENT(in), OPTIONAL :: ktype ! variable external type + LOGICAL, OPTIONAL :: ldxios ! xios write flag + LOGICAL :: llx ! local xios write flag + INTEGER :: ivid ! variable id + + llx = .FALSE. + IF(PRESENT(ldxios)) llx = ldxios + IF( llx ) THEN +#ifdef key_iomput + IF( kt == kwrite ) THEN + IF(lwp) write(numout,*) 'RESTART: write (XIOS 3D) ',trim(cdvar) + CALL xios_send_field(trim(cdvar), pvar) + ENDIF +#endif + ELSE + IF( kiomid > 0 ) THEN + IF( iom_file(kiomid)%nfid > 0 ) THEN + ivid = iom_varid( kiomid, cdvar, ldstop = .FALSE. ) + CALL iom_nf90_rstput( kt, kwrite, kiomid, cdvar, ivid, ktype, pv_r3d = pvar ) + ENDIF + ENDIF + ENDIF + END SUBROUTINE iom_rp3d + + + 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( cdname, pfield0d ) + CHARACTER(LEN=*), INTENT(in) :: cdname + REAL(wp) , INTENT(in) :: pfield0d +!! REAL(wp) , DIMENSION(jpi,jpj) :: zz ! masson +#if defined key_iomput +!!clem zz(:,:)=pfield0d +!!clem CALL xios_send_field(cdname, zz) + CALL xios_send_field(cdname, (/pfield0d/)) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield0d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p0d + + SUBROUTINE iom_p1d( cdname, pfield1d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:), INTENT(in) :: pfield1d +#if defined key_iomput + CALL xios_send_field( cdname, RESHAPE( (/pfield1d/), (/1,1,SIZE(pfield1d)/) ) ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield1d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p1d + + SUBROUTINE iom_p2d( cdname, pfield2d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:,:), INTENT(in) :: pfield2d +#if defined key_iomput + CALL xios_send_field(cdname, pfield2d) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield2d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p2d + + SUBROUTINE iom_p3d( cdname, pfield3d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: pfield3d +#if defined key_iomput + CALL xios_send_field( cdname, pfield3d ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield3d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p3d + + SUBROUTINE iom_p4d( cdname, pfield4d ) + CHARACTER(LEN=*) , INTENT(in) :: cdname + REAL(wp), DIMENSION(:,:,:,:), INTENT(in) :: pfield4d +#if defined key_iomput + CALL xios_send_field(cdname, pfield4d) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pfield4d ! useless test to avoid compilation warnings +#endif + END SUBROUTINE iom_p4d + + +#if defined key_iomput + !!---------------------------------------------------------------------- + !! 'key_iomput' 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, & + & nvertex, bounds_lon, bounds_lat, area ) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + CHARACTER(LEN=*) , INTENT(in) :: cdid + INTEGER , OPTIONAL, INTENT(in) :: ni_glo, nj_glo, ibegin, jbegin, ni, nj + INTEGER , OPTIONAL, INTENT(in) :: data_dim, data_ibegin, data_ni, data_jbegin, data_nj + INTEGER , OPTIONAL, INTENT(in) :: nvertex + REAL(wp), DIMENSION(:) , OPTIONAL, INTENT(in) :: lonvalue, latvalue + REAL(wp), 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 , & + & 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 , & + & 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=paxis ) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, n_glo=SIZE(paxis), value=paxis ) + ENDIF + IF( xios_is_valid_axis (cdid) ) CALL xios_set_axis_attr ( cdid, bounds=bounds ) + IF( xios_is_valid_axisgroup(cdid) ) CALL xios_set_axisgroup_attr( cdid, bounds=bounds ) + 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( TRIM(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 /= TRIM(cxios_context) ) CALL iom_swap( TRIM(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 + ! + INTEGER :: ni, nj + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask + LOGICAL, INTENT(IN) :: ldxios, ldrxios + !!---------------------------------------------------------------------- + ! + ni = nlei-nldi+1 + nj = nlej-nldj+1 + ! + CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) + CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) +!don't define lon and lat for restart reading context. + IF ( .NOT.ldrxios ) & + CALL iom_set_domain_attr("grid_"//cdgrd, lonvalue = RESHAPE(plon(nldi:nlei, nldj:nlej),(/ ni*nj /)), & + & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) + ! + 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(:,:,:) + CASE('U') ; zmask(2:jpim1,:,:) = tmask(2:jpim1,:,:) + tmask(3:jpi,:,:) ; CALL lbc_lnk( 'iom', zmask, 'U', 1. ) + CASE('V') ; zmask(:,2:jpjm1,:) = tmask(:,2:jpjm1,:) + tmask(:,3:jpj,:) ; CALL lbc_lnk( 'iom', zmask, 'V', 1. ) + CASE('W') ; zmask(:,:,2:jpk ) = tmask(:,:,1:jpkm1) + tmask(:,:,2:jpk) ; zmask(:,:,1) = tmask(:,:,1) + END SELECT + ! + CALL iom_set_domain_attr( "grid_"//cdgrd , mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,1),(/ni*nj /)) /= 0. ) + CALL iom_set_grid_attr ( "grid_"//cdgrd//"_3D", mask = RESHAPE(zmask(nldi:nlei,nldj:nlej,:),(/ni,nj,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, ni, nj + 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 + END SELECT + ! + ni = nlei-nldi+1 ! Dimensions of subdomain interior + nj = nlej-nldj+1 + ! + z_fld(:,:) = 1._wp + CALL lbc_lnk( 'iom', z_fld, cdgrd, -1. ) ! Working array for location of northfold + ! + ! Cell vertices that can be defined + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + 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 + ! + ! Cell vertices on boundries + DO jn = 1, 4 + CALL lbc_lnk( 'iom', z_bnds(jn,:,:,1), cdgrd, 1., pfillval=999._wp ) + CALL lbc_lnk( 'iom', z_bnds(jn,:,:,2), cdgrd, 1., pfillval=999._wp ) + END DO + ! + ! Zero-size cells at closed boundaries if cell points provided, + ! otherwise they are closed cells with unrealistic bounds + IF( PRESENT(plon_pnt) .AND. PRESENT(plat_pnt) ) THEN + IF( (nbondi == -1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN + DO jn = 1, 4 ! (West or jpni = 1), closed E-W + z_bnds(jn,1,:,1) = plat_pnt(1,:) ; z_bnds(jn,1,:,2) = plon_pnt(1,:) + END DO + ENDIF + IF( (nbondi == 1 .OR. nbondi == 2) .AND. .NOT. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6) ) THEN + DO jn = 1, 4 ! (East or jpni = 1), closed E-W + z_bnds(jn,nlci,:,1) = plat_pnt(nlci,:) ; z_bnds(jn,nlci,:,2) = plon_pnt(nlci,:) + END DO + ENDIF + IF( nbondj == -1 .OR. (nbondj == 2 .AND. jperio /= 2) ) THEN + DO jn = 1, 4 ! South or (jpnj = 1, not symmetric) + z_bnds(jn,:,1,1) = plat_pnt(:,1) ; z_bnds(jn,:,1,2) = plon_pnt(:,1) + END DO + ENDIF + IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio < 3 ) THEN + DO jn = 1, 4 ! (North or jpnj = 1), no north fold + z_bnds(jn,:,nlcj,1) = plat_pnt(:,nlcj) ; z_bnds(jn,:,nlcj,2) = plon_pnt(:,nlcj) + END DO + ENDIF + ENDIF + ! + IF( (nbondj == 1 .OR. nbondj == 2) .AND. jperio >= 3 ) THEN ! Rotate cells at the north fold + DO jj = 1, jpj + DO ji = 1, jpi + 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 + ELSE IF( nbondj == 2 .AND. jperio == 2 ) THEN ! Invert cells at the symmetric equator + DO ji = 1, jpi + z_rot(1:2,:) = z_bnds(3:4,ji,1,:) + z_rot(3:4,:) = z_bnds(1:2,ji,1,:) + z_bnds(:,ji,1,:) = z_rot(:,:) + END DO + ENDIF + ! + CALL iom_set_domain_attr("grid_"//cdgrd, bounds_lat = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,1),(/ 4,ni*nj /)), & + & bounds_lon = RESHAPE(z_bnds(:,nldi:nlei,nldj:nlej,2),(/ 4,ni*nj /)), 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 :: ni, nj, ix, iy + REAL(wp), DIMENSION(:), ALLOCATABLE :: zlon + !!---------------------------------------------------------------------- + ! + ni=nlei-nldi+1 ! define zonal mean domain (jpj*jpk) + nj=nlej-nldj+1 + ALLOCATE( zlon(ni*nj) ) ; zlon(:) = 0._wp + ! +! CALL dom_ngb( -168.53, 65.03, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots) + CALL dom_ngb( 180., 90., ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots) + CALL iom_set_domain_attr("gznl", ni_glo=jpiglo, nj_glo=jpjglo, ibegin=nimpp+nldi-2, jbegin=njmpp+nldj-2, ni=ni, nj=nj) + CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = 1-nldi, data_ni = jpi, data_jbegin = 1-nldj, data_nj = jpj) + CALL iom_set_domain_attr("gznl", lonvalue = zlon, & + & latvalue = RESHAPE(plat(nldi:nlei, nldj:nlej),(/ ni*nj /))) + CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=jpjglo) + ! + 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(wp), 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_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('ptrc_T' , freq_op=f_op, freq_offset=f_of) + f_op%timestep = nn_dttrc ; f_of%timestep = 0 ; CALL iom_set_field_attr('diad_T' , 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., ix, iy, cl1 ) + CALL iom_set_zoom_domain_attr('Eq'//cl1, ibegin=0, jbegin=iy-1, ni=jpiglo, 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 + CHARACTER(LEN=256) :: cltmpn !FUS needed for correct path with AGRIF + INTEGER :: iln !FUS needed for correct path with AGRIF + INTEGER :: idx + INTEGER :: jn + INTEGER :: itrlen + INTEGER :: iyear, imonth, iday, isec + REAL(wp) :: zsec + LOGICAL :: llexist + TYPE(xios_duration) :: output_freq + !!---------------------------------------------------------------------- + ! + DO jn = 1, 2 + ! + output_freq = xios_duration(0,0,0,0,0,0) + IF( jn == 1 ) CALL iom_get_file_attr( cdid, name = clname, output_freq = output_freq ) + IF( jn == 2 ) CALL iom_get_file_attr( cdid, name_suffix = clname ) + ! + IF ( TRIM(clname) /= '' ) THEN + ! + idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') + DO WHILE ( idx /= 0 ) + clname = clname(1:idx-1)//TRIM(cexper)//clname(idx+9:LEN_TRIM(clname)) + idx = INDEX(clname,'@expname@') + INDEX(clname,'@EXPNAME@') + END DO + ! + idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') + DO WHILE ( idx /= 0 ) + IF ( output_freq%timestep /= 0) THEN + WRITE(clfreq,'(I18,A2)')INT(output_freq%timestep),'ts' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%second /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%second),'s' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%minute /= 0 ) THEN + WRITE(clfreq,'(I18,A2)')INT(output_freq%minute),'mi' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%hour /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%hour),'h' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%day /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%day),'d' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%month /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%month),'m' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE IF ( output_freq%year /= 0 ) THEN + WRITE(clfreq,'(I19,A1)')INT(output_freq%year),'y' + itrlen = LEN_TRIM(ADJUSTL(clfreq)) + ELSE + CALL ctl_stop('error in the name of file id '//TRIM(cdid), & + & ' attribute output_freq is undefined -> cannot replace @freq@ in '//TRIM(clname) ) + ENDIF + clname = clname(1:idx-1)//TRIM(ADJUSTL(clfreq))//clname(idx+6:LEN_TRIM(clname)) + idx = INDEX(clname,'@freq@') + INDEX(clname,'@FREQ@') + END DO + ! + idx = INDEX(clname,'@startdate@') + INDEX(clname,'@STARTDATE@') + DO WHILE ( idx /= 0 ) + cldate = iom_sdate( fjulday - rdt / 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 - rdt / 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 + rdt / 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 + rdt / 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 + ! +!FUS IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) +!FUS see comment line 700 + IF( jn == 1 .AND. TRIM(Agrif_CFixed()) /= '0' ) THEN + iln = INDEX(clname,'/',BACK=.true.) + cltmpn = clname(1:iln) + clname = clname(iln+1:LEN_TRIM(clname)) + clname = TRIM(cltmpn)//TRIM(Agrif_CFixed())//'_'//TRIM(clname) + ENDIF +!FUS + IF( jn == 1 ) CALL iom_set_file_attr( cdid, name = clname ) + IF( jn == 2 ) CALL iom_set_file_attr( cdid, name_suffix = clname ) + ! + ENDIF + ! + END DO + ! + END SUBROUTINE iom_update_file_name + + + FUNCTION iom_sdate( pjday, ld24, ldfull ) + !!---------------------------------------------------------------------- + !! *** ROUTINE iom_sdate *** + !! + !! ** Purpose : send back the date corresponding to the given julian day + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: pjday ! julian day + LOGICAL , INTENT(in ), OPTIONAL :: ld24 ! true to force 24:00 instead of 00:00 + LOGICAL , INTENT(in ), OPTIONAL :: ldfull ! true to get the compleate date: yyyymmdd_hh:mm:ss + ! + CHARACTER(LEN=20) :: iom_sdate + CHARACTER(LEN=50) :: clfmt ! format used to write the date + INTEGER :: iyear, imonth, iday, ihour, iminute, isec + REAL(wp) :: zsec + LOGICAL :: ll24, llfull + !!---------------------------------------------------------------------- + ! + IF( PRESENT(ld24) ) THEN ; ll24 = ld24 + ELSE ; ll24 = .FALSE. + ENDIF + ! + IF( PRESENT(ldfull) ) THEN ; llfull = ldfull + ELSE ; llfull = .FALSE. + ENDIF + ! + CALL ju2ymds( pjday, iyear, imonth, iday, zsec ) + isec = NINT(zsec) + ! + IF ( ll24 .AND. isec == 0 ) THEN ! 00:00 of the next day -> move to 24:00 of the current day + CALL ju2ymds( pjday - 1., iyear, imonth, iday, zsec ) + isec = 86400 + ENDIF + ! + IF( iyear < 10000 ) THEN ; clfmt = "i4.4,2i2.2" ! format used to write the date + ELSE ; WRITE(clfmt, "('i',i1,',2i2.2')") INT(LOG10(REAL(iyear,wp))) + 1 + ENDIF + ! +!$AGRIF_DO_NOT_TREAT + ! needed in the conv + IF( llfull ) THEN + clfmt = TRIM(clfmt)//",'_',i2.2,':',i2.2,':',i2.2" + ihour = isec / 3600 + isec = MOD(isec, 3600) + iminute = isec / 60 + isec = MOD(isec, 60) + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday, ihour, iminute, isec ! date of the end of run + ELSE + WRITE(iom_sdate, '('//TRIM(clfmt)//')') iyear, imonth, iday ! date of the end of run + ENDIF +!$AGRIF_END_DO_NOT_TREAT + ! + END FUNCTION iom_sdate + +#else + !!---------------------------------------------------------------------- + !! NOT 'key_iomput' a few dummy routines + !!---------------------------------------------------------------------- + SUBROUTINE iom_setkt( kt, cdname ) + INTEGER , INTENT(in):: kt + CHARACTER(LEN=*), INTENT(in) :: cdname + IF( .FALSE. ) WRITE(numout,*) kt, cdname ! useless test to avoid compilation warnings + END SUBROUTINE iom_setkt + + SUBROUTINE iom_context_finalize( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname + IF( .FALSE. ) WRITE(numout,*) cdname ! useless test to avoid compilation warnings + END SUBROUTINE iom_context_finalize + +#endif + + LOGICAL FUNCTION iom_use( cdname ) + CHARACTER(LEN=*), INTENT(in) :: cdname +#if defined key_iomput + iom_use = xios_field_is_active( cdname ) +#else + iom_use = .FALSE. +#endif + END FUNCTION iom_use + + SUBROUTINE iom_miss_val( cdname, pmiss_val ) + CHARACTER(LEN=*), INTENT(in ) :: cdname + REAL(wp) , INTENT(out) :: pmiss_val +#if defined key_iomput + ! get missing value + CALL xios_get_field_attr( cdname, default_value = pmiss_val ) +#else + IF( .FALSE. ) WRITE(numout,*) cdname, pmiss_val ! useless test to avoid compilation warnings + IF( .FALSE. ) pmiss_val = 0._wp ! useless assignment to avoid compilation warnings +#endif + END SUBROUTINE iom_miss_val + + !!====================================================================== +END MODULE iom diff --git a/NEMO_4.0.4_surge/src/OCE/IOM/iom_def.F90 b/NEMO_4.0.4_surge/src/OCE/IOM/iom_def.F90 new file mode 100644 index 0000000..cf47bab --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/IOM/iom_def.F90 @@ -0,0 +1,84 @@ +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 + + IMPLICIT NONE + PRIVATE + + INTEGER, PARAMETER, PUBLIC :: jpdom_data = 1 !: ( 1 :jpiglo, 1 :jpjglo) !!gm to be suppressed + INTEGER, PARAMETER, PUBLIC :: jpdom_global = 2 !: ( 1 :jpiglo, 1 :jpjglo) + INTEGER, PARAMETER, PUBLIC :: jpdom_local = 3 !: One of the 3 following cases + INTEGER, PARAMETER, PUBLIC :: jpdom_local_full = 4 !: ( 1 :jpi , 1 :jpi ) + INTEGER, PARAMETER, PUBLIC :: jpdom_local_noextra = 5 !: ( 1 :nlci , 1 :nlcj ) + INTEGER, PARAMETER, PUBLIC :: jpdom_local_noovlap = 6 !: (nldi:nlei ,nldj:nlej ) + INTEGER, PARAMETER, PUBLIC :: jpdom_unknown = 7 !: No dimension checking + INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo = 8 !: + INTEGER, PARAMETER, PUBLIC :: jpdom_autoglo_xy = 9 !: Automatically set horizontal dimensions only + INTEGER, PARAMETER, PUBLIC :: jpdom_autodta = 10 !: + + 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 !: write single file restart using XIOS + INTEGER, PUBLIC :: nxioso !: type of restart file when writing using XIOS 1 - single, 2 - multiple +!XIOS read restart + LOGICAL, PUBLIC :: lrxios !: read single file restart using XIOS + LOGICAL, PUBLIC :: lxios_sini = .FALSE. ! is restart in a single file + LOGICAL, PUBLIC :: lxios_set = .FALSE. + + + + TYPE, PUBLIC :: file_descriptor + CHARACTER(LEN=240) :: name !: name of the file + 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 + INTEGER :: nlev ! number of vertical levels + END TYPE file_descriptor + TYPE(file_descriptor), DIMENSION(jpmax_files), PUBLIC :: iom_file !: array containing the info for all opened files + INTEGER, PARAMETER, PUBLIC :: max_rst_fields = 97 !: maximum number of restart variables defined in iom_set_rst_vars + TYPE, PUBLIC :: RST_FIELD + CHARACTER(len=30) :: vname = "NO_NAME" ! names of variables in restart file + CHARACTER(len=30) :: grid = "NO_GRID" + LOGICAL :: active =.FALSE. ! for restart write only: true - write field, false do not write field + END TYPE RST_FIELD +!$AGRIF_END_DO_NOT_TREAT + ! + TYPE(RST_FIELD), PUBLIC, SAVE :: rst_wfields(max_rst_fields), rst_rfields(max_rst_fields) + ! + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE iom_def diff --git a/NEMO_4.0.4_surge/src/OCE/IOM/iom_nf90.F90 b/NEMO_4.0.4_surge/src/OCE/IOM/iom_nf90.F90 new file mode 100644 index 0000000..f38308b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/IOM/iom_nf90.F90 @@ -0,0 +1,730 @@ +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 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 + + INTERFACE iom_nf90_get + MODULE PROCEDURE iom_nf90_g0d, iom_nf90_g123d + END INTERFACE + INTERFACE iom_nf90_rstput + MODULE PROCEDURE iom_nf90_rp0123d + END INTERFACE + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE iom_nf90_open( cdname, kiomid, ldwrt, ldok, kdompar, kdlev ) + !!--------------------------------------------------------------------- + !! *** 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, DIMENSION(2,5), INTENT(in ), OPTIONAL :: kdompar ! domain parameters: + INTEGER , INTENT(in ), OPTIONAL :: kdlev ! size of the third dimension + + CHARACTER(LEN=256) :: clinfo ! info character + CHARACTER(LEN=256) :: cltmp ! temporary character + CHARACTER(LEN=12 ) :: clfmt ! writing format + 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 + INTEGER :: ilevels ! vertical levels + !--------------------------------------------------------------------- + ! + clinfo = ' iom_nf90_open ~~~ ' + istop = nstop ! store the actual value of nstop + ! + ! !number of vertical levels + IF( PRESENT(kdlev) ) THEN ; ilevels = kdlev ! use input value (useful for sea-ice) + ELSE ; ilevels = jpk ! by default jpk + 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', kdompar(1,1), idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'y', kdompar(2,1), idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'nav_lev', jpk, idmy ), clinfo) + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo) + IF( PRESENT(kdlev) ) & + CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'numcat', kdlev, 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' , (/jpiglo, jpjglo/) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , kdompar(:,1) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , kdompar(:,2) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , kdompar(:,3) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', kdompar(:,4) ), clinfo) + CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , kdompar(:,5) ), 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)%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 + iom_file(kiomid)%nlev = ilevels + 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 the dimensions + INTEGER, INTENT( out), OPTIONAL :: kndims ! size of the 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( 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(wp), 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 + + + SUBROUTINE iom_nf90_g123d( 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(wp), DIMENSION(:) , INTENT( out), OPTIONAL :: pv_r1d ! read field (1D case) + REAL(wp), DIMENSION(:,:) , INTENT( out), OPTIONAL :: pv_r2d ! read field (2D case) + REAL(wp), 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 + + + 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 + CALL ctl_warn('iom_nf90_getatt: no attribute '//TRIM(cdatt)//' found') + 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 = '!' + 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( 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(wp) , INTENT(in), OPTIONAL :: pv_r0d ! written Od field + REAL(wp), DIMENSION( :), INTENT(in), OPTIONAL :: pv_r1d ! written 1d field + REAL(wp), DIMENSION(:, : ), INTENT(in), OPTIONAL :: pv_r2d ! written 2d field + REAL(wp), 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 + CHARACTER(LEN= 12), DIMENSION(5) :: cltmp ! temporary character + INTEGER :: if90id ! nf90 file identifier + INTEGER :: idmy ! dummy variable + 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 + INTEGER :: idim3 ! id of the third dimension + !--------------------------------------------------------------------- + ! + 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 + ! Warning: we must use the same character length in an array constructor (at least for gcc compiler) + cltmp = (/ 'nav_lon ', 'nav_lat ', 'nav_lev ', 'time_counter', 'numcat ' /) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(1)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(1) ), clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(2)), NF90_FLOAT , (/ 1, 2 /), iom_file(kiomid)%nvid(2) ), clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(3)), NF90_FLOAT , (/ 3 /), iom_file(kiomid)%nvid(3) ), clinfo) + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(4)), NF90_DOUBLE, (/ 4 /), iom_file(kiomid)%nvid(4) ), clinfo) + ! 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)%cn_var(1:4) = cltmp(1:4) + iom_file(kiomid)%ndims(1:4) = (/ 2, 2, 1, 1 /) + IF( NF90_INQ_DIMID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN ! add a 5th variable corresponding to the 5th dimension + CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cltmp(5)), NF90_FLOAT , (/ 5 /), iom_file(kiomid)%nvid(5) ), clinfo) + iom_file(kiomid)%nvars = 5 + iom_file(kiomid)%luld(5) = .FALSE. + iom_file(kiomid)%cn_var(5) = cltmp(5) + iom_file(kiomid)%ndims(5) = 1 + ENDIF + ! trick: defined to 0 to say that dimension variables are defined but not yet written + iom_file(kiomid)%dimsz(1, 1) = 0 + 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 + IF( SIZE(pv_r1d,1) == jpk ) THEN ; idim3 = 3 + ELSE ; idim3 = 5 + ENDIF + idims = 2 ; idimid(1:idims) = (/idim3,4/) + ELSEIF( PRESENT(pv_r2d) ) THEN ; idims = 3 ; idimid(1:idims) = (/1,2 ,4/) + ELSEIF( PRESENT(pv_r3d) ) THEN + IF( SIZE(pv_r3d,3) == jpk ) THEN ; idim3 = 3 + ELSE ; idim3 = 5 + ENDIF + idims = 4 ; idimid(1:idims) = (/1,2,idim3,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) == (nlei - nldi + 1) .AND. idimsz(2) == (nlej - nldj + 1) ) THEN + ix1 = nldi ; ix2 = nlei ; iy1 = nldj ; iy2 = nlej + ELSEIF( idimsz(1) == nlci .AND. idimsz(2) == nlcj ) THEN + ix1 = 1 ; ix2 = nlci ; iy1 = 1 ; iy2 = nlcj + 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, 1) == 0 ) THEN + CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lon' , idmy ) , clinfo ) + CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, glamt(ix1:ix2, iy1:iy2) ), clinfo ) + CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lat' , idmy ) , clinfo ) + CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gphit(ix1:ix2, iy1:iy2) ), clinfo ) + CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'nav_lev' , idmy ), clinfo ) + CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, gdept_1d ), clinfo ) + IF( NF90_INQ_VARID( if90id, 'numcat', idmy ) == nf90_noerr ) THEN + CALL iom_nf90_check( NF90_PUT_VAR ( if90id, idmy, (/ (idlv, idlv = 1,iom_file(kiomid)%nlev) /)), clinfo ) + ENDIF + ! +++ WRONG VALUE: to be improved but not really useful... + CALL iom_nf90_check( NF90_INQ_VARID( if90id, 'time_counter', idmy ), clinfo ) + CALL iom_nf90_check( NF90_PUT_VAR( if90id, idmy, kt ), clinfo ) + ! update the values of the variables dimensions size + CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 1, len = iom_file(kiomid)%dimsz(1,1) ), clinfo ) + CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 2, len = iom_file(kiomid)%dimsz(2,1) ), clinfo ) + iom_file(kiomid)%dimsz(1:2, 2) = iom_file(kiomid)%dimsz(1:2, 1) + CALL iom_nf90_check( NF90_INQUIRE_DIMENSION( if90id, 3, len = iom_file(kiomid)%dimsz(1,3) ), clinfo ) + iom_file(kiomid)%dimsz(1 , 4) = 1 ! unlimited dimension + 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 + + + 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/NEMO_4.0.4_surge/src/OCE/IOM/prtctl.F90 b/NEMO_4.0.4_surge/src/OCE/IOM/prtctl.F90 new file mode 100644 index 0000000..d61a427 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/IOM/prtctl.F90 @@ -0,0 +1,585 @@ +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 +#if defined key_nemocice_decomp + USE ice_domain_size, only: nx_global, ny_global +#endif + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing + + IMPLICIT NONE + PRIVATE + + INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: numid + INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlditl , nldjtl ! first, last indoor index for each i-domain + INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nleitl , nlejtl ! first, last indoor index for each j-domain + INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nimpptl, njmpptl ! i-, j-indexes for each processor + INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: nlcitl , nlcjtl ! dimensions of every subdomain + INTEGER , DIMENSION(:), ALLOCATABLE, SAVE :: ibonitl, ibonjtl ! + + REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: t_ctll , s_ctll ! previous tracer trend values + REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: u_ctll , v_ctll ! previous velocity trend values + + INTEGER :: ktime ! time step + + PUBLIC prt_ctl ! called by all subroutines + PUBLIC prt_ctl_info ! called by all subroutines + PUBLIC prt_ctl_init ! called by opa.F90 + PUBLIC sub_dom ! called by opa.F90 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE prt_ctl (tab2d_1, tab3d_1, mask1, clinfo1, tab2d_2, tab3d_2, & + & mask2, clinfo2, kdim, clinfo3 ) + !!---------------------------------------------------------------------- + !! *** 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 ln_ctl 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 looks like: CALL prt_ctl(tab3d_1=tn). + !! + !! tab2d_1 : first 2D array + !! tab3d_1 : first 3D 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 + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1 + REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_1 + REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask1 + CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo1 + REAL(wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2 + REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: tab3d_2 + REAL(wp), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask2 + CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo2 + INTEGER , INTENT(in), OPTIONAL :: kdim + CHARACTER (len=*) , INTENT(in), OPTIONAL :: clinfo3 + ! + CHARACTER (len=15) :: cl2 + INTEGER :: jn, sind, eind, kdir,j_id + REAL(wp) :: zsum1, zsum2, zvctl1, zvctl2 + REAL(wp), DIMENSION(jpi,jpj) :: ztab2d_1, ztab2d_2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2, ztab3d_1, ztab3d_2 + !!---------------------------------------------------------------------- + + ! Arrays, scalars initialization + kdir = jpkm1 + cl2 = '' + zsum1 = 0.e0 + zsum2 = 0.e0 + zvctl1 = 0.e0 + zvctl2 = 0.e0 + ztab2d_1(:,:) = 0.e0 + ztab2d_2(:,:) = 0.e0 + ztab3d_1(:,:,:) = 0.e0 + ztab3d_2(:,:,:) = 0.e0 + zmask1 (:,:,:) = 1.e0 + zmask2 (:,:,:) = 1.e0 + + ! Control of optional arguments + IF( PRESENT(clinfo2) ) cl2 = clinfo2 + IF( PRESENT(kdim) ) kdir = kdim + IF( PRESENT(tab2d_1) ) ztab2d_1(:,:) = tab2d_1(:,:) + IF( PRESENT(tab2d_2) ) ztab2d_2(:,:) = tab2d_2(:,:) + IF( PRESENT(tab3d_1) ) ztab3d_1(:,:,1:kdir) = tab3d_1(:,:,1:kdir) + IF( PRESENT(tab3d_2) ) ztab3d_2(:,:,1:kdir) = tab3d_2(:,:,1:kdir) + IF( PRESENT(mask1) ) zmask1 (:,:,:) = mask1 (:,:,:) + IF( PRESENT(mask2) ) zmask2 (:,:,:) = mask2 (:,:,:) + + IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number + sind = narea + eind = narea + ELSE ! processors total number + sind = 1 + eind = ijsplt + ENDIF + + ! Loop over each sub-domain, i.e. the total number of processors ijsplt + DO jn = sind, eind + ! Set logical unit + j_id = numid(jn - narea + 1) + ! Set indices for the SUM control + IF( .NOT. lsp_area ) THEN + IF (lk_mpp .AND. jpnij > 1) THEN + nictls = MAX( 1, nlditl(jn) ) + nictle = MIN(jpi, nleitl(jn) ) + njctls = MAX( 1, nldjtl(jn) ) + njctle = MIN(jpj, nlejtl(jn) ) + ! Do not take into account the bound of the domain + IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls) + IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls) + IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nleitl(jn) - 1) + IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, nlejtl(jn) - 1) + ELSE + nictls = MAX( 1, nimpptl(jn) - 1 + nlditl(jn) ) + nictle = MIN(jpi, nimpptl(jn) - 1 + nleitl(jn) ) + njctls = MAX( 1, njmpptl(jn) - 1 + nldjtl(jn) ) + njctle = MIN(jpj, njmpptl(jn) - 1 + nlejtl(jn) ) + ! Do not take into account the bound of the domain + IF( ibonitl(jn) == -1 .OR. ibonitl(jn) == 2 ) nictls = MAX(2, nictls) + IF( ibonjtl(jn) == -1 .OR. ibonjtl(jn) == 2 ) njctls = MAX(2, njctls) + IF( ibonitl(jn) == 1 .OR. ibonitl(jn) == 2 ) nictle = MIN(nictle, nimpptl(jn) + nleitl(jn) - 2) + IF( ibonjtl(jn) == 1 .OR. ibonjtl(jn) == 2 ) njctle = MIN(njctle, njmpptl(jn) + nlejtl(jn) - 2) + ENDIF + ENDIF + + IF( PRESENT(clinfo3)) THEN + IF ( clinfo3 == 'tra' ) THEN + zvctl1 = t_ctll(jn) + zvctl2 = s_ctll(jn) + ELSEIF ( clinfo3 == 'dyn' ) THEN + zvctl1 = u_ctll(jn) + zvctl2 = v_ctll(jn) + ENDIF + ENDIF + + ! Compute the sum control + ! 2D arrays + IF( PRESENT(tab2d_1) ) THEN + zsum1 = SUM( ztab2d_1(nictls:nictle,njctls:njctle)*zmask1(nictls:nictle,njctls:njctle,1) ) + zsum2 = SUM( ztab2d_2(nictls:nictle,njctls:njctle)*zmask2(nictls:nictle,njctls:njctle,1) ) + ENDIF + + ! 3D arrays + IF( PRESENT(tab3d_1) ) THEN + zsum1 = SUM( ztab3d_1(nictls:nictle,njctls:njctle,1:kdir)*zmask1(nictls:nictle,njctls:njctle,1:kdir) ) + zsum2 = SUM( ztab3d_2(nictls:nictle,njctls:njctle,1:kdir)*zmask2(nictls:nictle,njctls:njctle,1:kdir) ) + ENDIF + + ! Print the result + IF( PRESENT(clinfo3) ) THEN + WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1-zvctl1, cl2, zsum2-zvctl2 + SELECT CASE( clinfo3 ) + CASE ( 'tra-ta' ) + t_ctll(jn) = zsum1 + CASE ( 'tra' ) + t_ctll(jn) = zsum1 + s_ctll(jn) = zsum2 + CASE ( 'dyn' ) + u_ctll(jn) = zsum1 + v_ctll(jn) = zsum2 + END SELECT + ELSEIF ( PRESENT(clinfo2) .OR. PRESENT(tab2d_2) .OR. PRESENT(tab3d_2) ) THEN + WRITE(j_id,FMT='(a,D23.16,3x,a,D23.16)')clinfo1, zsum1, cl2, zsum2 + ELSE + WRITE(j_id,FMT='(a,D23.16)')clinfo1, zsum1 + ENDIF + + ENDDO + ! + END SUBROUTINE prt_ctl + + + SUBROUTINE prt_ctl_info (clinfo1, ivar1, clinfo2, ivar2, itime) + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_info *** + !! + !! ** Purpose : - print information without any computation + !! + !! ** Action : - input arguments + !! clinfo1 : information about the ivar1 + !! ivar1 : value to print + !! clinfo2 : information about the ivar2 + !! ivar2 : value to print + !!---------------------------------------------------------------------- + CHARACTER (len=*), INTENT(in) :: clinfo1 + INTEGER , INTENT(in), OPTIONAL :: ivar1 + CHARACTER (len=*), INTENT(in), OPTIONAL :: clinfo2 + INTEGER , INTENT(in), OPTIONAL :: ivar2 + INTEGER , INTENT(in), OPTIONAL :: itime + ! + INTEGER :: jn, sind, eind, iltime, j_id + !!---------------------------------------------------------------------- + + IF( lk_mpp .AND. jpnij > 1 ) THEN ! processor number + sind = narea + eind = narea + ELSE ! total number of processors + sind = 1 + eind = ijsplt + ENDIF + + ! Set to zero arrays at each new time step + IF( PRESENT(itime) ) THEN + iltime = itime + IF( iltime > ktime ) THEN + t_ctll(:) = 0.e0 ; s_ctll(:) = 0.e0 + u_ctll(:) = 0.e0 ; v_ctll(:) = 0.e0 + ktime = iltime + ENDIF + ENDIF + + ! Loop over each sub-domain, i.e. number of processors ijsplt + DO jn = sind, eind + ! + j_id = numid(jn - narea + 1) ! Set logical unit + ! + IF( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN + WRITE(j_id,*)clinfo1, ivar1, clinfo2, ivar2 + ELSEIF ( PRESENT(ivar1) .AND. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN + WRITE(j_id,*)clinfo1, ivar1, clinfo2 + ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. PRESENT(ivar2) ) THEN + WRITE(j_id,*)clinfo1, ivar1, ivar2 + ELSEIF ( PRESENT(ivar1) .AND. .NOT. PRESENT(clinfo2) .AND. .NOT. PRESENT(ivar2) ) THEN + WRITE(j_id,*)clinfo1, ivar1 + ELSE + WRITE(j_id,*)clinfo1 + ENDIF + ! + END DO + ! + END SUBROUTINE prt_ctl_info + + + SUBROUTINE prt_ctl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE prt_ctl_init *** + !! + !! ** Purpose : open ASCII files & compute indices + !!---------------------------------------------------------------------- + INTEGER :: jn, sind, eind, j_id + CHARACTER (len=28) :: clfile_out + CHARACTER (len=23) :: clb_name + CHARACTER (len=19) :: cl_run + !!---------------------------------------------------------------------- + + ! Allocate arrays + ALLOCATE( nlditl(ijsplt) , nleitl(ijsplt) , nimpptl(ijsplt) , ibonitl(ijsplt) , & + & nldjtl(ijsplt) , nlejtl(ijsplt) , njmpptl(ijsplt) , ibonjtl(ijsplt) , & + & nlcitl(ijsplt) , t_ctll(ijsplt) , u_ctll (ijsplt) , & + & nlcjtl(ijsplt) , s_ctll(ijsplt) , v_ctll (ijsplt) ) + + ! Initialization + t_ctll(:) = 0.e0 + s_ctll(:) = 0.e0 + u_ctll(:) = 0.e0 + v_ctll(:) = 0.e0 + ktime = 1 + + IF( lk_mpp .AND. jpnij > 1 ) THEN + sind = narea + eind = narea + clb_name = "('mpp.output_',I4.4)" + cl_run = 'MULTI processor run' + ! use indices for each area computed by mpp_init subroutine + nlditl(1:jpnij) = nldit(:) + nleitl(1:jpnij) = nleit(:) + nldjtl(1:jpnij) = nldjt(:) + nlejtl(1:jpnij) = nlejt(:) + ! + nimpptl(1:jpnij) = nimppt(:) + njmpptl(1:jpnij) = njmppt(:) + ! + nlcitl(1:jpnij) = nlcit(:) + nlcjtl(1:jpnij) = nlcjt(:) + ! + ibonitl(1:jpnij) = ibonit(:) + ibonjtl(1:jpnij) = ibonjt(:) + ELSE + sind = 1 + eind = ijsplt + clb_name = "('mono.output_',I4.4)" + cl_run = 'MONO processor run ' + ! compute indices for each area as done in mpp_init subroutine + CALL sub_dom + ENDIF + + ALLOCATE( numid(eind-sind+1) ) + + DO jn = sind, eind + WRITE(clfile_out,FMT=clb_name) jn-1 + CALL ctl_opn( numid(jn -narea + 1), clfile_out, 'REPLACE', 'FORMATTED', 'SEQUENTIAL', 1, numout, .FALSE. ) + j_id = numid(jn -narea + 1) + WRITE(j_id,*) + WRITE(j_id,*) ' L O D Y C - I P S L' + WRITE(j_id,*) ' O P A model' + WRITE(j_id,*) ' Ocean General Circulation Model' + WRITE(j_id,*) ' version OPA 9.0 (2005) ' + WRITE(j_id,*) + WRITE(j_id,*) ' PROC number: ', jn + WRITE(j_id,*) + WRITE(j_id,FMT="(19x,a20)")cl_run + + ! Print the SUM control indices + IF( .NOT. lsp_area ) THEN + nictls = nimpptl(jn) + nlditl(jn) - 1 + nictle = nimpptl(jn) + nleitl(jn) - 1 + njctls = njmpptl(jn) + nldjtl(jn) - 1 + njctle = njmpptl(jn) + nlejtl(jn) - 1 + ENDIF + WRITE(j_id,*) + WRITE(j_id,*) 'prt_ctl : Sum control indices' + WRITE(j_id,*) '~~~~~~~' + WRITE(j_id,*) + WRITE(j_id,9000)' nlej = ', nlejtl(jn), ' ' + WRITE(j_id,9000)' ------------- njctle = ', njctle, ' -------------' + WRITE(j_id,9001)' | |' + WRITE(j_id,9001)' | |' + WRITE(j_id,9001)' | |' + WRITE(j_id,9002)' nictls = ', nictls, ' nictle = ', nictle + WRITE(j_id,9002)' nldi = ', nlditl(jn), ' nlei = ', nleitl(jn) + WRITE(j_id,9001)' | |' + WRITE(j_id,9001)' | |' + WRITE(j_id,9001)' | |' + WRITE(j_id,9004)' njmpp = ',njmpptl(jn),' ------------- njctls = ', njctls, ' -------------' + WRITE(j_id,9003)' nimpp = ', nimpptl(jn), ' nldj = ', nldjtl(jn), ' ' + WRITE(j_id,*) + WRITE(j_id,*) + +9000 FORMAT(a41,i4.4,a14) +9001 FORMAT(a59) +9002 FORMAT(a20,i4.4,a36,i4.4) +9003 FORMAT(a20,i4.4,a17,i4.4) +9004 FORMAT(a11,i4.4,a26,i4.4,a14) + END DO + ! + END SUBROUTINE prt_ctl_init + + + SUBROUTINE sub_dom + !!---------------------------------------------------------------------- + !! *** ROUTINE sub_dom *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! CAUTION: + !! This part has been extracted from the mpp_init + !! subroutine and names of variables/arrays have been + !! slightly changed to avoid confusion but the computation + !! is exactly the same. Any modification about indices of + !! each sub-domain in the mppini.F90 module should be reported + !! here. + !! + !! ** 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 + !! Type : jperio global periodic condition + !! + !! ** Action : - set domain parameters + !! nimpp : longitudinal index + !! njmpp : latitudinal index + !! narea : number for local area + !! nlcil : first dimension + !! nlcjl : second dimension + !! nbondil : mark for "east-west local boundary" + !! nbondjl : mark for "north-south local boundary" + !! + !! History : + !! ! 94-11 (M. Guyon) Original code + !! ! 95-04 (J. Escobar, M. Imbard) + !! ! 98-02 (M. Guyon) FETI method + !! ! 98-05 (M. Imbard, J. Escobar, L. Colombet ) SHMEM and MPI versions + !! 8.5 ! 02-08 (G. Madec) F90 : free form + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: & + ii, ij, & ! temporary integers + irestil, irestjl, & ! " " + ijpi , ijpj, nlcil, & ! temporary logical unit + nlcjl , nbondil, nbondjl, & + nrecil, nrecjl, nldil, nleil, nldjl, nlejl + + INTEGER, DIMENSION(jpi,jpj) :: iimpptl, ijmpptl, ilcitl, ilcjtl ! workspace + REAL(wp) :: zidom, zjdom ! temporary scalars + INTEGER :: inum ! local logical unit + !!---------------------------------------------------------------------- + + ! + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! Computation of local domain sizes ilcitl() ilcjtl() + ! These dimensions depend on global sizes isplt,jsplt and jpiglo,jpjglo + ! The subdomains are squares leeser than or equal to the global + ! dimensions divided by the number of processors minus the overlap + ! array (cf. par_oce.F90). + +#if defined key_nemocice_decomp + ijpi = ( nx_global+2-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls + ijpj = ( ny_global+2-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls +#else + ijpi = ( jpiglo-2*nn_hls + (isplt-1) ) / isplt + 2*nn_hls + ijpj = ( jpjglo-2*nn_hls + (jsplt-1) ) / jsplt + 2*nn_hls +#endif + + + nrecil = 2 * nn_hls + nrecjl = 2 * nn_hls + irestil = MOD( jpiglo - nrecil , isplt ) + irestjl = MOD( jpjglo - nrecjl , jsplt ) + + IF( irestil == 0 ) irestil = isplt +#if defined key_nemocice_decomp + + ! In order to match CICE the size of domains in NEMO has to be changed + ! The last line of blocks (west) will have fewer points + DO jj = 1, jsplt + DO ji=1, isplt-1 + ilcitl(ji,jj) = ijpi + END DO + ilcitl(isplt,jj) = jpiglo - (isplt - 1) * (ijpi - nrecil) + END DO + +#else + + DO jj = 1, jsplt + DO ji = 1, irestil + ilcitl(ji,jj) = ijpi + END DO + DO ji = irestil+1, isplt + ilcitl(ji,jj) = ijpi -1 + END DO + END DO + +#endif + + IF( irestjl == 0 ) irestjl = jsplt +#if defined key_nemocice_decomp + + ! Same change to domains in North-South direction as in East-West. + DO ji = 1, isplt + DO jj=1, jsplt-1 + ilcjtl(ji,jj) = ijpj + END DO + ilcjtl(ji,jsplt) = jpjglo - (jsplt - 1) * (ijpj - nrecjl) + END DO + +#else + + DO ji = 1, isplt + DO jj = 1, irestjl + ilcjtl(ji,jj) = ijpj + END DO + DO jj = irestjl+1, jsplt + ilcjtl(ji,jj) = ijpj -1 + END DO + END DO + +#endif + zidom = nrecil + DO ji = 1, isplt + zidom = zidom + ilcitl(ji,1) - nrecil + END DO + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*)' sum ilcitl(i,1) = ', zidom, ' jpiglo = ', jpiglo + + zjdom = nrecjl + DO jj = 1, jsplt + zjdom = zjdom + ilcjtl(1,jj) - nrecjl + END DO + IF(lwp) WRITE(numout,*)' sum ilcitl(1,j) = ', zjdom, ' jpjglo = ', jpjglo + IF(lwp) WRITE(numout,*) + + + ! 2. Index arrays for subdomains + ! ------------------------------- + + iimpptl(:,:) = 1 + ijmpptl(:,:) = 1 + + IF( isplt > 1 ) THEN + DO jj = 1, jsplt + DO ji = 2, isplt + iimpptl(ji,jj) = iimpptl(ji-1,jj) + ilcitl(ji-1,jj) - nrecil + END DO + END DO + ENDIF + + IF( jsplt > 1 ) THEN + DO jj = 2, jsplt + DO ji = 1, isplt + ijmpptl(ji,jj) = ijmpptl(ji,jj-1)+ilcjtl(ji,jj-1)-nrecjl + END DO + END DO + ENDIF + + ! 3. Subdomain description + ! ------------------------ + + DO jn = 1, ijsplt + ii = 1 + MOD( jn-1, isplt ) + ij = 1 + (jn-1) / isplt + nimpptl(jn) = iimpptl(ii,ij) + njmpptl(jn) = ijmpptl(ii,ij) + nlcitl (jn) = ilcitl (ii,ij) + nlcil = nlcitl (jn) + nlcjtl (jn) = ilcjtl (ii,ij) + nlcjl = nlcjtl (jn) + nbondjl = -1 ! general case + IF( jn > isplt ) nbondjl = 0 ! first row of processor + IF( jn > (jsplt-1)*isplt ) nbondjl = 1 ! last row of processor + IF( jsplt == 1 ) nbondjl = 2 ! one processor only in j-direction + ibonjtl(jn) = nbondjl + + nbondil = 0 ! + IF( MOD( jn, isplt ) == 1 ) nbondil = -1 ! + IF( MOD( jn, isplt ) == 0 ) nbondil = 1 ! + IF( isplt == 1 ) nbondil = 2 ! one processor only in i-direction + ibonitl(jn) = nbondil + + nldil = 1 + nn_hls + nleil = nlcil - nn_hls + IF( nbondil == -1 .OR. nbondil == 2 ) nldil = 1 + IF( nbondil == 1 .OR. nbondil == 2 ) nleil = nlcil + nldjl = 1 + nn_hls + nlejl = nlcjl - nn_hls + IF( nbondjl == -1 .OR. nbondjl == 2 ) nldjl = 1 + IF( nbondjl == 1 .OR. nbondjl == 2 ) nlejl = nlcjl + nlditl(jn) = nldil + nleitl(jn) = nleil + nldjtl(jn) = nldjl + nlejtl(jn) = nlejl + END DO + ! + ! Save processor layout in layout_prtctl.dat file + IF(lwp) THEN + CALL ctl_opn( inum, 'layout_prtctl.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE(inum,'(a)') 'nproc nlcil nlcjl nldil nldjl nleil nlejl nimpptl njmpptl ibonitl ibonjtl' + ! + DO jn = 1, ijsplt + WRITE(inum,'(i5,6i6,4i8)') jn-1,nlcitl(jn), nlcjtl(jn), & + & nlditl(jn), nldjtl(jn), & + & nleitl(jn), nlejtl(jn), & + & nimpptl(jn), njmpptl(jn), & + & ibonitl(jn), ibonjtl(jn) + END DO + CLOSE(inum) + END IF + ! + ! + END SUBROUTINE sub_dom + + !!====================================================================== +END MODULE prtctl diff --git a/NEMO_4.0.4_surge/src/OCE/IOM/restart.F90 b/NEMO_4.0.4_surge/src/OCE/IOM/restart.F90 new file mode 100644 index 0000000..831afcf --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/IOM/restart.F90 @@ -0,0 +1,339 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! rst_opn : open the ocean restart file + !! rst_write : write the ocean restart file + !! rst_read : read the ocean restart file + !!---------------------------------------------------------------------- + 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 (eos bn2 routine) + USE trdmxl_oce ! ocean active mixed layer tracers trends variables + ! + USE in_out_manager ! I/O manager + USE iom ! I/O module + USE ioipsl, ONLY : ju2ymds ! for calendar + USE diurnal_bulk + USE lib_mpp ! distribued memory computing library + + IMPLICIT NONE + PRIVATE + + PUBLIC rst_opn ! routine called by step module + PUBLIC rst_write ! routine called by step module + PUBLIC rst_read ! routine called by istate module + PUBLIC rst_read_open ! routine called in rst_read and (possibly) in dom_vvl_init + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !! + INTEGER :: iyear, imonth, iday + REAL (wp) :: zsec + REAL (wp) :: zfjulday + 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 ( ln_rstdate ) THEN + zfjulday = fjulday + rdt / rday + 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(clkt, '(i4.4,2i2.2)') iyear, imonth, iday + ELSE + IF( nitrst > 999999999 ) THEN ; WRITE(clkt, * ) nitrst + ELSE ; WRITE(clkt, '(i8.8)') nitrst + ENDIF + 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 +#if defined key_iomput + cwxios_context = "rstw_"//TRIM(ADJUSTL(clkt)) + IF( TRIM(Agrif_CFixed()) == '0' ) THEN + clpname = clname + ELSE + clpname = TRIM(Agrif_CFixed())//"_"//clname + ENDIF + CALL iom_init( cwxios_context, TRIM(clpath)//TRIM(clpname), .false. ) + CALL xios_update_calendar(nitrst) + CALL iom_swap( cxios_context ) +#else + clinfo = 'Can not use XIOS in rst_opn' + CALL ctl_stop(TRIM(clinfo)) +#endif + ENDIF + lrst_oce = .TRUE. + ENDIF + ENDIF + ! + END SUBROUTINE rst_opn + + + SUBROUTINE rst_write( kt ) + !!--------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step + !!---------------------------------------------------------------------- + IF(lwxios) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'rdt' , rdt , ldxios = lwxios) ! dynamics time step + 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, 'ub' , ub, ldxios = lwxios ) ! before fields + CALL iom_rstput( kt, nitrst, numrow, 'vb' , vb, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'tb' , tsb(:,:,:,jp_tem), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sb' , tsb(:,:,:,jp_sal), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sshb' , sshb, ldxios = lwxios ) + ! + CALL iom_rstput( kt, nitrst, numrow, 'un' , un, ldxios = lwxios ) ! now fields + CALL iom_rstput( kt, nitrst, numrow, 'vn' , vn, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'tn' , tsn(:,:,:,jp_tem), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sn' , tsn(:,:,:,jp_sal), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sshn' , sshn, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'rhop' , rhop, ldxios = lwxios ) + ! extra variable needed for the ice sheet coupling + IF ( ln_iscpl ) THEN + CALL iom_rstput( kt, nitrst, numrow, 'tmask' , tmask, ldxios = lwxios ) ! need to extrapolate T/S + CALL iom_rstput( kt, nitrst, numrow, 'umask' , umask, ldxios = lwxios ) ! need to correct barotropic velocity + CALL iom_rstput( kt, nitrst, numrow, 'vmask' , vmask, ldxios = lwxios ) ! need to correct barotropic velocity + CALL iom_rstput( kt, nitrst, numrow, 'smask' , ssmask, ldxios = lwxios) ! need to correct barotropic velocity + CALL iom_rstput( kt, nitrst, numrow, 'e3t_n', e3t_n(:,:,:), ldxios = lwxios ) ! need to compute temperature correction + CALL iom_rstput( kt, nitrst, numrow, 'e3u_n', e3u_n(:,:,:), ldxios = lwxios ) ! need to compute bt conservation + CALL iom_rstput( kt, nitrst, numrow, 'e3v_n', e3v_n(:,:,:), ldxios = lwxios ) ! need to compute bt conservation + CALL iom_rstput( kt, nitrst, numrow, 'gdepw_n', gdepw_n(:,:,:), ldxios = lwxios ) ! need to compute extrapolation if vvl + END IF + ENDIF + CALL iom_rstput( kt, nitrst, numrow, 'neos' , REAL(neos) , ldxios = lwxios) ! equation of state + !CALL iom_rstput( kt, nitrst, numrow, 'neos' , neos , ktype = jp_i1, ldxios = lwxios) ! equation of state + + + IF (ln_diurnal) CALL iom_rstput( kt, nitrst, numrow, 'Dsst', x_dsst, ldxios = lwxios ) + IF(lwxios) CALL iom_swap( cxios_context ) + 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( cwxios_context ) + 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(lc) :: clpath ! full path to ocean output restart file + !!---------------------------------------------------------------------- + ! + 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) + IF(.NOT.lxios_set) lrxios = lrxios.AND.lxios_sini + IF( lrxios) THEN + crxios_context = 'nemo_rst' + IF( .NOT.lxios_set ) THEN + IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS' + CALL iom_init( crxios_context, ld_tmppatch = .false. ) + lxios_set = .TRUE. + ENDIF + ENDIF + IF( TRIM(Agrif_CFixed()) /= '0' .AND. lrxios) THEN + CALL iom_init( crxios_context, ld_tmppatch = .false. ) + IF(lwp) WRITE(numout,*) 'Enable restart reading by XIOS for AGRIF' + lxios_set = .TRUE. + ENDIF + ENDIF + + END SUBROUTINE rst_read_open + + + SUBROUTINE rst_read + !!---------------------------------------------------------------------- + !! *** ROUTINE rst_read *** + !! + !! ** Purpose : Read files for NetCDF restart + !! + !! ** Method : Read in restart.nc file fields which are necessary for restart + !!---------------------------------------------------------------------- + REAL(wp) :: zrdt + REAL(wp) :: zeos + INTEGER :: jk + REAL(wp), DIMENSION(jpi, jpj, jpk) :: w3d + !!---------------------------------------------------------------------- + + CALL rst_read_open ! open restart for reading (if not already opened) + + IF ( ln_rst_eos ) THEN + ! Check equation of state used is consistent with the restart + IF( iom_varid( numror, 'neos') == -1) THEN + CALL ctl_stop( 'restart, rst_read: variable neos not found. STOP check that the equations of state in the restart file and in the namelist nameos are consistent and use ln_rst_eos=F') + ELSE + CALL iom_get( numror, 'neos', zeos, ldxios = lrxios ) + IF ( INT(zeos) /= neos ) CALL ctl_stop( 'restart, rst_read: equation of state used in restart file differs from namelist nameos') + ENDIF + ENDIF + + ! Check dynamics and tracer time-step consistency and force Euler restart if changed + IF( iom_varid( numror, 'rdt', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, 'rdt', zrdt, ldxios = lrxios ) + IF( zrdt /= rdt ) neuler = 0 + ENDIF + + CALL iom_delay_rst( 'READ', 'OCE', numror ) ! read only ocean delayed global communication variables + + ! Diurnal DSST + IF( ln_diurnal ) CALL iom_get( numror, jpdom_autoglo, 'Dsst' , x_dsst, ldxios = lrxios ) + IF ( ln_diurnal_only ) THEN + IF(lwp) WRITE( numout, * ) & + & "rst_read:- ln_diurnal_only set, setting rhop=rau0" + rhop = rau0 + CALL iom_get( numror, jpdom_autoglo, 'tn' , w3d, ldxios = lrxios ) + tsn(:,:,1,jp_tem) = w3d(:,:,1) + RETURN + ENDIF + + IF( iom_varid( numror, 'ub', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_autoglo, 'ub' , ub, ldxios = lrxios ) ! before fields + CALL iom_get( numror, jpdom_autoglo, 'vb' , vb, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'tb' , tsb(:,:,:,jp_tem), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'sb' , tsb(:,:,:,jp_sal), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'sshb' , sshb, ldxios = lrxios ) + ELSE + neuler = 0 + ENDIF + ! + CALL iom_get( numror, jpdom_autoglo, 'un' , un, ldxios = lrxios ) ! now fields + CALL iom_get( numror, jpdom_autoglo, 'vn' , vn, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'tn' , tsn(:,:,:,jp_tem), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'sn' , tsn(:,:,:,jp_sal), ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'sshn' , sshn, ldxios = lrxios ) + IF( iom_varid( numror, 'rhop', ldstop = .FALSE. ) > 0 ) THEN + CALL iom_get( numror, jpdom_autoglo, 'rhop' , rhop, ldxios = lrxios ) ! now potential density + ELSE + CALL eos( tsn, rhd, rhop, gdept_n(:,:,:) ) + ENDIF + ! + IF( neuler == 0 ) THEN ! Euler restart (neuler=0) + tsb (:,:,:,:) = tsn (:,:,:,:) ! all before fields set to now values + ub (:,:,:) = un (:,:,:) + vb (:,:,:) = vn (:,:,:) + sshb (:,:) = sshn (:,:) + ! + IF( .NOT.ln_linssh ) THEN + DO jk = 1, jpk + e3t_b(:,:,jk) = e3t_n(:,:,jk) + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE rst_read + + !!===================================================================== +END MODULE restart diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lbc_lnk_multi_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_lnk_multi_generic.h90 new file mode 100644 index 0000000..fd49a2c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_lnk_multi_generic.h90 @@ -0,0 +1,92 @@ +#if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j) +# define PTR_TYPE TYPE(PTR_2D) +# define PTR_ptab pt2d +#endif +#if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k) +# define PTR_TYPE TYPE(PTR_3D) +# define PTR_ptab pt3d +#endif +#if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l) REAL(wp), DIMENSION(i,j,k,l) +# define PTR_TYPE TYPE(PTR_4D) +# define PTR_ptab pt4d +#endif + + SUBROUTINE ROUTINE_MULTI( 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 & + & , kfillmode, pfillval, lsend, lrecv, ihlcom ) + !!--------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: pt1 ! arrays on which the lbc is applied + ARRAY_TYPE(:,:,:,:) , OPTIONAL, TARGET, INTENT(inout) :: pt2 , pt3 , pt4 , pt5 , pt6 , pt7 , pt8 , pt9 , & + & pt10 , pt11 , pt12 , pt13 , pt14 , pt15 , pt16 + 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 + REAL(wp) , INTENT(in ) :: psgn1 ! sign used across the north fold + REAL(wp) , OPTIONAL , INTENT(in ) :: psgn2 , psgn3 , psgn4 , psgn5 , psgn6 , psgn7 , psgn8 , psgn9, & + & psgn10, psgn11, psgn12, psgn13, psgn14, psgn15, psgn16 + 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, DIMENSION(4), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out + INTEGER , OPTIONAL , INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated + !! + INTEGER :: kfld ! number of elements that will be attributed + PTR_TYPE , DIMENSION(16) :: ptab_ptr ! pointer array + CHARACTER(len=1) , DIMENSION(16) :: cdna_ptr ! nature of ptab_ptr grid-points + REAL(wp) , DIMENSION(16) :: psgn_ptr ! sign used across the north fold boundary + !!--------------------------------------------------------------------- + ! + kfld = 0 ! initial array of pointer size + ! + ! ! Load the first array + CALL ROUTINE_LOAD( pt1, cdna1, psgn1, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + ! ! Look if more arrays are added + IF( PRESENT(psgn2 ) ) CALL ROUTINE_LOAD( pt2 , cdna2 , psgn2 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn3 ) ) CALL ROUTINE_LOAD( pt3 , cdna3 , psgn3 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn4 ) ) CALL ROUTINE_LOAD( pt4 , cdna4 , psgn4 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn5 ) ) CALL ROUTINE_LOAD( pt5 , cdna5 , psgn5 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn6 ) ) CALL ROUTINE_LOAD( pt6 , cdna6 , psgn6 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn7 ) ) CALL ROUTINE_LOAD( pt7 , cdna7 , psgn7 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn8 ) ) CALL ROUTINE_LOAD( pt8 , cdna8 , psgn8 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn9 ) ) CALL ROUTINE_LOAD( pt9 , cdna9 , psgn9 , ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn10) ) CALL ROUTINE_LOAD( pt10, cdna10, psgn10, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn11) ) CALL ROUTINE_LOAD( pt11, cdna11, psgn11, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn12) ) CALL ROUTINE_LOAD( pt12, cdna12, psgn12, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn13) ) CALL ROUTINE_LOAD( pt13, cdna13, psgn13, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn14) ) CALL ROUTINE_LOAD( pt14, cdna14, psgn14, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn15) ) CALL ROUTINE_LOAD( pt15, cdna15, psgn15, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + IF( PRESENT(psgn16) ) CALL ROUTINE_LOAD( pt16, cdna16, psgn16, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + ! + CALL lbc_lnk_ptr( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) + ! + END SUBROUTINE ROUTINE_MULTI + + + SUBROUTINE ROUTINE_LOAD( ptab, cdna, psgn, ptab_ptr, cdna_ptr, psgn_ptr, kfld ) + !!--------------------------------------------------------------------- + ARRAY_TYPE(:,:,:,:) , TARGET, INTENT(inout) :: ptab ! arrays on which the lbc is applied + CHARACTER(len=1) , INTENT(in ) :: cdna ! nature of pt2d array grid-points + REAL(wp) , INTENT(in ) :: psgn ! sign used across the north fold boundary + PTR_TYPE , DIMENSION(:), INTENT(inout) :: ptab_ptr ! array of pointers + CHARACTER(len=1), DIMENSION(:), INTENT(inout) :: cdna_ptr ! nature of pt2d_array array grid-points + REAL(wp) , 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)%PTR_ptab => ptab + cdna_ptr(kfld) = cdna + psgn_ptr(kfld) = psgn + ! + END SUBROUTINE ROUTINE_LOAD + +#undef ARRAY_TYPE +#undef PTR_TYPE +#undef PTR_ptab diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_ext_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_ext_generic.h90 new file mode 100644 index 0000000..0ddba55 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_ext_generic.h90 @@ -0,0 +1,157 @@ +! !== IN: ptab is an array ==! +#define NAT_IN(k) cd_nat +#define SGN_IN(k) psgn +#define F_SIZE(ptab) 1 +#if defined DIM_2d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +#endif +#define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) + + SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kextj ) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kextj ! extra halo width at north fold, declared before its use in ARRAY_TYPE + ARRAY_TYPE(:,1-kextj:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points + REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary + ! + INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ijt, iju, ipjm1 + !!---------------------------------------------------------------------- + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ipl = L_SIZE(ptab) ! 4th - + ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) + ! + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction + CASE DEFAULT ; ipj = 4 ! several proc along the i-direction + END SELECT + ! + ipjm1 = ipj-1 + + ! + DO jf = 1, ipf ! Loop on the number of arrays to be treated + ! + SELECT CASE ( npolj ) + ! + CASE ( 3 , 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) + END DO + ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2-jh,:,:,jf) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 2, jpiglo-1 + iju = jpiglo-ji+1 + ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf) + END DO + ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2-jh,:,:,jf) + ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2-jh,:,:,jf) + END DO + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) + ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3-jh,:,:,jf) + END DO + ARRAY_IN(1,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3-jh,:,:,jf) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ARRAY_IN(ji,ipj-1+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf) + ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3-jh,:,:,jf) + END DO + END DO + DO jh = 0, kextj + ARRAY_IN( 1 ,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3-jh,:,:,jf) + ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3-jh,:,:,jf) + END DO + END SELECT + ! + CASE ( 5 , 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1-jh,:,:,jf) + END DO + END DO + CASE ( 'U' ) ! U-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1-jh,:,:,jf) + END DO + ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1-jh,:,:,jf) + END DO + CASE ( 'V' ) ! V-point + DO jh = 0, kextj + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ARRAY_IN(ji,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2-jh,:,:,jf) + END DO + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) + END DO + CASE ( 'F' ) ! F-point + DO jh = 0, kextj + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ARRAY_IN(ji,ipj+jh ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2-jh,:,:,jf) + END DO + ARRAY_IN(jpiglo,ipj+jh,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2-jh,:,:,jf) + END DO + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + ARRAY_IN(:, 1:1-kextj ,:,:,jf) = 0._wp + ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp + CASE ( 'F' ) ! F-point + ARRAY_IN(:,ipj:ipj+kextj,:,:,jf) = 0._wp + END SELECT + ! + END SELECT ! npolj + ! + END DO + ! + END SUBROUTINE ROUTINE_NFD + +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef NAT_IN +#undef SGN_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_generic.h90 new file mode 100644 index 0000000..beae788 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_generic.h90 @@ -0,0 +1,175 @@ +#if defined MULTI +# define NAT_IN(k) cd_nat(k) +# define SGN_IN(k) psgn(k) +# define F_SIZE(ptab) kfld +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) +# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) +# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) +# endif +#else +! !== IN: ptab is an array ==! +# define NAT_IN(k) cd_nat +# define SGN_IN(k) psgn +# define F_SIZE(ptab) 1 +# if defined DIM_2d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) SIZE(ptab,4) +# endif +# define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +#endif + +#if defined MULTI + SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays +#else + SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn ) +#endif + ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points + REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary + ! + INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ijt, iju, ipjm1 + !!---------------------------------------------------------------------- + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ipl = L_SIZE(ptab) ! 4th - + ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) + ! + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; ipj = nlcj ! 1 proc only along the i-direction + CASE DEFAULT ; ipj = 4 ! several proc along the i-direction + END SELECT + ipjm1 = ipj-1 + + ! + DO jf = 1, ipf ! Loop on the number of arrays to be treated + ! + SELECT CASE ( npolj ) + ! + CASE ( 3 , 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) + END DO + ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-2,:,:,jf) + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+2 + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) + END DO + ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-2,:,:,jf) + ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-2,:,:,jf) + DO ji = jpiglo/2, jpiglo-1 + iju = jpiglo-ji+1 + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) + END DO + CASE ( 'V' ) ! V-point + DO ji = 2, jpiglo + ijt = jpiglo-ji+2 + ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) + ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-3,:,:,jf) + END DO + ARRAY_IN(1,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,ipj-3,:,:,jf) + CASE ( 'F' ) ! F-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji+1 + ARRAY_IN(ji,ipj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) + ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-3,:,:,jf) + END DO + ARRAY_IN( 1 ,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN( 2 ,ipj-3,:,:,jf) + ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-1,ipj-3,:,:,jf) + END SELECT + ! + CASE ( 5 , 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-1,:,:,jf) + END DO + CASE ( 'U' ) ! U-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-1,:,:,jf) + END DO + ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-1,:,:,jf) + CASE ( 'V' ) ! V-point + DO ji = 1, jpiglo + ijt = jpiglo-ji+1 + ARRAY_IN(ji,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipj-2,:,:,jf) + END DO + DO ji = jpiglo/2+1, jpiglo + ijt = jpiglo-ji+1 + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(ijt,ipjm1,:,:,jf) + END DO + CASE ( 'F' ) ! F-point + DO ji = 1, jpiglo-1 + iju = jpiglo-ji + ARRAY_IN(ji,ipj ,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipj-2,:,:,jf) + END DO + ARRAY_IN(jpiglo,ipj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(jpiglo-2,ipj-2,:,:,jf) + DO ji = jpiglo/2+1, jpiglo-1 + iju = jpiglo-ji + ARRAY_IN(ji,ipjm1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(iju,ipjm1,:,:,jf) + END DO + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'U' , 'V' , 'W' ) ! T-, U-, V-, W-points + ARRAY_IN(:, 1 ,:,:,jf) = 0._wp + ARRAY_IN(:,ipj,:,:,jf) = 0._wp + CASE ( 'F' ) ! F-point + ARRAY_IN(:,ipj,:,:,jf) = 0._wp + END SELECT + ! + END SELECT ! npolj + ! + END DO + ! + END SUBROUTINE ROUTINE_NFD + +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef NAT_IN +#undef SGN_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_nogather_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_nogather_generic.h90 new file mode 100644 index 0000000..f7f542b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lbc_nfd_nogather_generic.h90 @@ -0,0 +1,356 @@ +#if defined MULTI +# define NAT_IN(k) cd_nat(k) +# define SGN_IN(k) psgn(k) +# define F_SIZE(ptab) kfld +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D),INTENT(inout)::ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D),INTENT(inout)::ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) +# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) +# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) +# endif +# define ARRAY2_TYPE(i,j,k,l,f) TYPE(PTR_4D),INTENT(inout)::ptab2(f) +# define J_SIZE(ptab2) SIZE(ptab2(1)%pt4d,2) +# define ARRAY2_IN(i,j,k,l,f) ptab2(f)%pt4d(i,j,k,l) +#else +! !== IN: ptab is an array ==! +# define NAT_IN(k) cd_nat +# define SGN_IN(k) psgn +# define F_SIZE(ptab) 1 +# if defined DIM_2d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) SIZE(ptab,4) +# endif +# define ARRAY2_IN(i,j,k,l,f) ptab2(i,j,k,l) +# define J_SIZE(ptab2) SIZE(ptab2,2) +# define ARRAY_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY_IN(i,j,k,l,f) +# define ARRAY2_TYPE(i,j,k,l,f) REAL(wp),INTENT(inout)::ARRAY2_IN(i,j,k,l,f) +#endif + + SUBROUTINE ROUTINE_NFD( ptab, ptab2, cd_nat, psgn, kfld ) + !!---------------------------------------------------------------------- + !! + !! ** Purpose : lateral boundary condition : North fold treatment + !! without allgather exchanges. + !! + !!---------------------------------------------------------------------- + ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied + ARRAY2_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points + REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary + INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays + ! + INTEGER :: ji, jj, jk, jl, jh, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: ijt, iju, ijpj, ijpjp1, ijta, ijua, jia, startloop, endloop + LOGICAL :: l_fast_exchanges + !!---------------------------------------------------------------------- + ipj = J_SIZE(ptab2) ! 2nd dimension of input array + ipk = K_SIZE(ptab) ! 3rd dimension of output array + ipl = L_SIZE(ptab) ! 4th - + ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) + ! + ! Security check for further developments + IF ( ipf > 1 ) CALL ctl_stop( 'STOP', 'lbc_nfd_nogather: multiple fields not allowed. Revise implementation...' ) + ! + ijpj = 1 ! index of first modified line + ijpjp1 = 2 ! index + 1 + + ! 2nd dimension determines exchange speed + IF (ipj == 1 ) THEN + l_fast_exchanges = .TRUE. + ELSE + l_fast_exchanges = .FALSE. + ENDIF + ! + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ! + SELECT CASE ( npolj ) + ! + CASE ( 3, 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + ! + CASE ( 'T' , 'W' ) ! T-, W-point + IF ( nimpp /= 1 ) THEN ; startloop = 1 + ELSE ; startloop = 2 + ENDIF + ! + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) + END DO + END DO; END DO + IF( nimpp == 1 ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + ARRAY_IN(1,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-2,jk,jl,jf) + END DO; END DO + ENDIF + ! + IF ( .NOT. l_fast_exchanges ) THEN + IF( nimpp >= jpiglo/2+1 ) THEN + startloop = 1 + ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = nlci + 1 + ENDIF + IF( startloop <= nlci ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + jia = ji + nimpp - 1 + ijta = jpiglo - jia + 2 + IF( ijta >= startloop+nimpp-1 .AND. ijta < jia ) THEN + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijta-nimpp+1,nlcj-1,jk,jl,jf) + ELSE + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) + ENDIF + END DO + END DO; END DO + ENDIF + ENDIF + + CASE ( 'U' ) ! U-point + IF( nimpp + nlci - 1 /= jpiglo ) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) + END DO + END DO; END DO + IF (nimpp .eq. 1) THEN + ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) + ENDIF + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) + ENDIF + ! + IF ( .NOT. l_fast_exchanges ) THEN + IF( nimpp + nlci - 1 /= jpiglo ) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF( nimpp >= jpiglo/2 ) THEN + startloop = 1 + ELSEIF( ( nimpp+nlci-1 >= jpiglo/2 ) .AND. ( nimpp < jpiglo/2 ) ) THEN + startloop = jpiglo/2 - nimpp + 1 + ELSE + startloop = endloop + 1 + ENDIF + IF( startloop <= endloop ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + jia = ji + nimpp - 1 + ijua = jpiglo - jia + 1 + IF( ijua >= startloop+nimpp-1 .AND. ijua < jia ) THEN + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(ijua-nimpp+1,nlcj-1,jk,jl,jf) + ELSE + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) + ENDIF + END DO + END DO; END DO + ENDIF + ENDIF + ! + CASE ( 'V' ) ! V-point + IF( nimpp /= 1 ) THEN + startloop = 1 + ELSE + startloop = 2 + ENDIF + IF ( .NOT. l_fast_exchanges ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, nlci + ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) + END DO + END DO; END DO + ENDIF + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, nlci + ijt=jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 4 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) + END DO + END DO; END DO + IF (nimpp .eq. 1) THEN + ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(3,nlcj-3,:,:,jf) + ENDIF + CASE ( 'F' ) ! F-point + IF( nimpp + nlci - 1 /= jpiglo ) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF ( .NOT. l_fast_exchanges ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) + END DO + END DO; END DO + ENDIF + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) + END DO + END DO; END DO + IF (nimpp .eq. 1) THEN + ARRAY_IN(1,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-3,:,:,jf) + IF ( .NOT. l_fast_exchanges ) & + ARRAY_IN(1,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(2,nlcj-2,:,:,jf) + ENDIF + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + ARRAY_IN(nlci,nlcj,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-3,:,:,jf) + IF ( .NOT. l_fast_exchanges ) & + ARRAY_IN(nlci,nlcj-1,:,:,jf) = SGN_IN(jf) * ARRAY_IN(nlci-1,nlcj-2,:,:,jf) + ENDIF + ! + END SELECT + ! + CASE ( 5, 6 ) ! * North fold F-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + CASE ( 'T' , 'W' ) ! T-, W-point + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) + END DO + END DO; END DO + ! + CASE ( 'U' ) ! U-point + IF( nimpp + nlci - 1 /= jpiglo ) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) + END DO + END DO; END DO + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + DO jl = 1, ipl; DO jk = 1, ipk + ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-1,jk,jl,jf) + END DO; END DO + ENDIF + ! + CASE ( 'V' ) ! V-point + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + ARRAY_IN(ji,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpj,jk,jl,jf) + END DO + END DO; END DO + + IF ( .NOT. l_fast_exchanges ) THEN + IF( nimpp >= jpiglo/2+1 ) THEN + startloop = 1 + ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = nlci + 1 + ENDIF + IF( startloop <= nlci ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, nlci + ijt = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 3 + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(ijt,ijpjp1,jk,jl,jf) + END DO + END DO; END DO + ENDIF + ENDIF + ! + CASE ( 'F' ) ! F-point + IF( nimpp + nlci - 1 /= jpiglo ) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = 1, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + ARRAY_IN(ji,nlcj ,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpj,jk,jl,jf) + END DO + END DO; END DO + IF((nimpp + nlci - 1) .eq. jpiglo) THEN + DO jl = 1, ipl; DO jk = 1, ipk + ARRAY_IN(nlci,nlcj,jk,jl,jf) = SGN_IN(jf) * ARRAY_IN(nlci-2,nlcj-2,jk,jl,jf) + END DO; END DO + ENDIF + ! + IF ( .NOT. l_fast_exchanges ) THEN + IF( nimpp + nlci - 1 /= jpiglo ) THEN + endloop = nlci + ELSE + endloop = nlci - 1 + ENDIF + IF( nimpp >= jpiglo/2+1 ) THEN + startloop = 1 + ELSEIF( nimpp+nlci-1 >= jpiglo/2+1 .AND. nimpp < jpiglo/2+1 ) THEN + startloop = jpiglo/2+1 - nimpp + 1 + ELSE + startloop = endloop + 1 + ENDIF + IF( startloop <= endloop ) THEN + DO jl = 1, ipl; DO jk = 1, ipk + DO ji = startloop, endloop + iju = jpiglo - ji - nimpp - nfiimpp(isendto(1),jpnj) + 2 + ARRAY_IN(ji,nlcj-1,jk,jl,jf) = SGN_IN(jf) * ARRAY2_IN(iju,ijpjp1,jk,jl,jf) + END DO + END DO; END DO + ENDIF + ENDIF + ! + END SELECT + ! + CASE DEFAULT ! * closed : the code probably never go through + ! + WRITE(*,*) 'lbc_nfd_nogather_generic: You should not have seen this print! error?', npolj + ! + END SELECT ! npolj + ! + END DO ! End jf loop + END SUBROUTINE ROUTINE_NFD +#undef ARRAY_TYPE +#undef ARRAY_IN +#undef NAT_IN +#undef SGN_IN +#undef J_SIZE +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE +#undef ARRAY2_TYPE +#undef ARRAY2_IN diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lbclnk.F90 b/NEMO_4.0.4_surge/src/OCE/LBC/lbclnk.F90 new file mode 100644 index 0000000..900e9c6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lbclnk.F90 @@ -0,0 +1,507 @@ +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 + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_lnk + MODULE PROCEDURE mpp_lnk_2d , mpp_lnk_3d , mpp_lnk_4d + END INTERFACE + INTERFACE lbc_lnk_ptr + MODULE PROCEDURE mpp_lnk_2d_ptr , mpp_lnk_3d_ptr , mpp_lnk_4d_ptr + END INTERFACE + INTERFACE lbc_lnk_multi + MODULE PROCEDURE lbc_lnk_2d_multi, lbc_lnk_3d_multi, lbc_lnk_4d_multi + END INTERFACE + ! + INTERFACE lbc_lnk_icb + MODULE PROCEDURE mpp_lnk_2d_icb + END INTERFACE + + INTERFACE mpp_nfd + MODULE PROCEDURE mpp_nfd_2d , mpp_nfd_3d , mpp_nfd_4d + MODULE PROCEDURE mpp_nfd_2d_ptr, mpp_nfd_3d_ptr, mpp_nfd_4d_ptr + END INTERFACE + + PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions + PUBLIC lbc_lnk_multi ! modified ocean/ice lateral boundary conditions + PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions + +#if defined key_mpp_mpi +!$AGRIF_DO_NOT_TREAT + INCLUDE 'mpif.h' +!$AGRIF_END_DO_NOT_TREAT +#endif + + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! *** load_ptr_(2,3,4)d *** + !! + !! * Dummy Argument : + !! in ==> 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_(2,3,4)d_multi *** + !! *** load_ptr_(2,3,4)d *** + !! + !! * Argument : dummy argument use in lbc_lnk_multi_... routines + !! + !!---------------------------------------------------------------------- + +# define DIM_2d +# define ROUTINE_LOAD load_ptr_2d +# define ROUTINE_MULTI lbc_lnk_2d_multi +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_2d + +# define DIM_3d +# define ROUTINE_LOAD load_ptr_3d +# define ROUTINE_MULTI lbc_lnk_3d_multi +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_3d + +# define DIM_4d +# define ROUTINE_LOAD load_ptr_4d +# define ROUTINE_MULTI lbc_lnk_4d_multi +# include "lbc_lnk_multi_generic.h90" +# undef ROUTINE_MULTI +# undef ROUTINE_LOAD +# undef DIM_4d + + !!---------------------------------------------------------------------- + !! *** routine mpp_lnk_(2,3,4)d *** + !! + !! * Argument : dummy argument use in mpp_lnk_... routines + !! ptab : array or 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) + !!---------------------------------------------------------------------- + ! + ! !== 2D array and array of 2D pointer ==! + ! +# define DIM_2d +# define ROUTINE_LNK mpp_lnk_2d +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_2d_ptr +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# undef MULTI +# undef DIM_2d + ! + ! !== 3D array and array of 3D pointer ==! + ! +# define DIM_3d +# define ROUTINE_LNK mpp_lnk_3d +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_3d_ptr +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# undef MULTI +# undef DIM_3d + ! + ! !== 4D array and array of 4D pointer ==! + ! +# define DIM_4d +# define ROUTINE_LNK mpp_lnk_4d +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# define MULTI +# define ROUTINE_LNK mpp_lnk_4d_ptr +# include "mpp_lnk_generic.h90" +# undef ROUTINE_LNK +# undef MULTI +# undef DIM_4d + + !!---------------------------------------------------------------------- + !! *** routine mpp_nfd_(2,3,4)d *** + !! + !! * Argument : dummy argument use in mpp_nfd_... routines + !! ptab : array or 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) + !!---------------------------------------------------------------------- + ! + ! !== 2D array and array of 2D pointer ==! + ! +# define DIM_2d +# define ROUTINE_NFD mpp_nfd_2d +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_2d_ptr +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_2d + ! + ! !== 3D array and array of 3D pointer ==! + ! +# define DIM_3d +# define ROUTINE_NFD mpp_nfd_3d +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_3d_ptr +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_3d + ! + ! !== 4D array and array of 4D pointer ==! + ! +# define DIM_4d +# define ROUTINE_NFD mpp_nfd_4d +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD mpp_nfd_4d_ptr +# include "mpp_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_4d + + + !!====================================================================== + + + + SUBROUTINE mpp_lbc_north_icb( 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(wp), 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(wp) , 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, ildi, ilei, iilb + INTEGER :: ipj, ij, iproc + ! + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e + !!---------------------------------------------------------------------- +#if defined key_mpp_mpi + ! + ipj=4 + ALLOCATE( ztab_e(jpiglo, 1-kextj:ipj+kextj) , & + & znorthloc_e(jpimax, 1-kextj:ipj+kextj) , & + & znorthgloio_e(jpimax, 1-kextj:ipj+kextj,jpni) ) + ! + ztab_e(:,:) = 0._wp + znorthloc_e(:,:) = 0._wp + ! + 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.) + ! + DO jr = 1, ndim_rank_north ! recover the global north array + iproc = nrank_north(jr) + 1 + ildi = nldit (iproc) + ilei = nleit (iproc) + iilb = nimppt(iproc) + DO jj = 1-kextj, ipj+kextj + DO ji = ildi, ilei + ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) + END DO + END DO + 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 mpp_lbc_north_icb + + + SUBROUTINE mpp_lnk_2d_icb( 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 + !! kexti : number of columns for extra outer halo + !! kextj : number of rows for extra outer halo + !! nbondi : mark for "east-west local boundary" + !! nbondj : mark for "north-south local boundary" + !! noea : number for local neighboring processors + !! nowe : number for local neighboring processors + !! noso : number for local neighboring processors + !! nono : number for local neighboring processors + !!---------------------------------------------------------------------- + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + REAL(wp), 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(wp) , 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 key_mpi_isend + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend + !! + REAL(wp), DIMENSION(1-kexti:jpi+kexti,nn_hls+kextj,2) :: r2dns, r2dsn + REAL(wp), 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(jpim1-kexti: jpim1 ,:) ! east + pt2d( jpi :jpi+kexti,:) = pt2d( 2 :2+kexti,:) ! west + ! + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d( 1-kexti :nn_hls ,:) = 0._wp ! east except at F-point + pt2d(jpi-nn_hls+1:jpi+kexti,:) = 0._wp ! west + ENDIF + ! ! North-South boundaries + IF( l_Jperio ) THEN !* cyclic (only with no mpp j-split) + pt2d(:,1-kextj: 1 ) = pt2d(:,jpjm1-kextj: jpjm1) ! north + pt2d(:, jpj :jpj+kextj) = pt2d(:, 2 :2+kextj) ! south + ELSE !* closed + IF( .NOT. cd_type == 'F' ) pt2d(:, 1-kextj :nn_hls ) = 0._wp ! north except at F-point + pt2d(:,jpj-nn_hls+1:jpj+kextj) = 0._wp ! south + ENDIF + ! + + ! north fold treatment + ! ----------------------- + IF( npolj /= 0 ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1-kextj:jpj+kextj), cd_type, psgn, kextj ) + CASE DEFAULT ; CALL mpp_lbc_north_icb( 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 + ! + SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions + CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) + iihom = jpi-nreci-kexti + DO jl = 1, ipreci + r2dew(:,jl,1) = pt2d(nn_hls+jl,:) + r2dwe(:,jl,1) = pt2d(iihom +jl,:) + END DO + END SELECT + ! + ! ! Migrations + imigr = ipreci * ( jpj + 2*kextj ) + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req1 ) + CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) + CALL mppsend( 2, r2dwe(1-kextj,1,1), imigr, noea, ml_req2 ) + CALL mpprecv( 1, r2dew(1-kextj,1,2), imigr, noea ) + CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 1, r2dew(1-kextj,1,1), imigr, nowe, ml_req1 ) + CALL mpprecv( 2, r2dwe(1-kextj,1,2), imigr, nowe ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + iihom = jpi - nn_hls + ! + SELECT CASE ( nbondi ) + CASE ( -1 ) + DO jl = 1, ipreci + pt2d(iihom+jl,:) = r2dew(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, ipreci + pt2d(jl-kexti,:) = r2dwe(:,jl,2) + pt2d(iihom+jl,:) = r2dew(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, ipreci + pt2d(jl-kexti,:) = r2dwe(:,jl,2) + END DO + END SELECT + + + ! 3. North and south directions + ! ----------------------------- + ! always closed : we play only with the neigbours + ! + IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions + ijhom = jpj-nrecj-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.) + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req1 ) + CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + CASE ( 0 ) + CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) + CALL mppsend( 4, r2dsn(1-kexti,1,1), imigr, nono, ml_req2 ) + CALL mpprecv( 3, r2dns(1-kexti,1,2), imigr, nono ) + CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + CALL mpi_wait(ml_req2,ml_stat,ml_err) + CASE ( 1 ) + CALL mppsend( 3, r2dns(1-kexti,1,1), imigr, noso, ml_req1 ) + CALL mpprecv( 4, r2dsn(1-kexti,1,2), imigr, noso ) + CALL mpi_wait(ml_req1,ml_stat,ml_err) + END SELECT + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ! Write Dirichlet lateral conditions + ijhom = jpj - nn_hls + ! + SELECT CASE ( nbondj ) + CASE ( -1 ) + DO jl = 1, iprecj + pt2d(:,ijhom+jl) = r2dns(:,jl,2) + END DO + CASE ( 0 ) + DO jl = 1, iprecj + pt2d(:,jl-kextj) = r2dsn(:,jl,2) + pt2d(:,ijhom+jl) = r2dns(:,jl,2) + END DO + CASE ( 1 ) + DO jl = 1, iprecj + pt2d(:,jl-kextj) = r2dsn(:,jl,2) + END DO + END SELECT + ! + END SUBROUTINE mpp_lnk_2d_icb + +END MODULE lbclnk + diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lbcnfd.F90 b/NEMO_4.0.4_surge/src/OCE/LBC/lbcnfd.F90 new file mode 100644 index 0000000..bb69dc6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lbcnfd.F90 @@ -0,0 +1,169 @@ +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_3d and lbc_nfd_2d routines + !! lbc_nfd_3d : lateral boundary condition: North fold treatment for a 3D arrays (lbc_nfd) + !! lbc_nfd_2d : lateral boundary condition: North fold treatment for a 2D arrays (lbc_nfd) + !! lbc_nfd_nogather : generic interface for lbc_nfd_nogather_3d and + !! lbc_nfd_nogather_2d routines (designed for use + !! with ln_nnogather to avoid global width arrays + !! mpi all gather operations) + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + INTERFACE lbc_nfd + MODULE PROCEDURE lbc_nfd_2d , lbc_nfd_3d , lbc_nfd_4d + MODULE PROCEDURE lbc_nfd_2d_ptr, lbc_nfd_3d_ptr, lbc_nfd_4d_ptr + MODULE PROCEDURE lbc_nfd_2d_ext + END INTERFACE + ! + INTERFACE lbc_nfd_nogather +! ! Currently only 4d array version is needed + MODULE PROCEDURE lbc_nfd_nogather_2d , lbc_nfd_nogather_3d + MODULE PROCEDURE lbc_nfd_nogather_4d + MODULE PROCEDURE lbc_nfd_nogather_2d_ptr, lbc_nfd_nogather_3d_ptr +! MODULE PROCEDURE lbc_nfd_nogather_4d_ptr + END INTERFACE + + TYPE, PUBLIC :: PTR_2D !: array of 2D pointers (also used in lib_mpp) + REAL(wp), DIMENSION (:,:) , POINTER :: pt2d + END TYPE PTR_2D + TYPE, PUBLIC :: PTR_3D !: array of 3D pointers (also used in lib_mpp) + REAL(wp), DIMENSION (:,:,:) , POINTER :: pt3d + END TYPE PTR_3D + TYPE, PUBLIC :: PTR_4D !: array of 4D pointers (also used in lib_mpp) + REAL(wp), DIMENSION (:,:,:,:), POINTER :: pt4d + END TYPE PTR_4D + + PUBLIC lbc_nfd ! north fold conditions + PUBLIC lbc_nfd_nogather ! north fold conditions (no allgather case) + + INTEGER, PUBLIC, PARAMETER :: jpmaxngh = 3 !: + INTEGER, PUBLIC :: nsndto, nfsloop, nfeloop !: + INTEGER, PUBLIC, DIMENSION (jpmaxngh) :: isendto !: processes to which communicate + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + !!---------------------------------------------------------------------- + !! *** routine lbc_nfd_(2,3,4)d *** + !!---------------------------------------------------------------------- + !! + !! ** Purpose : lateral boundary condition + !! North fold treatment without processor exchanges. + !! + !! ** Method : + !! + !! ** Action : ptab with updated values along the north fold + !!---------------------------------------------------------------------- + ! + ! !== 2D array and array of 2D pointer ==! + ! +# define DIM_2d +# define ROUTINE_NFD lbc_nfd_2d +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_2d_ptr +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_2d + ! + ! !== 2D array with extra haloes ==! + ! +# define DIM_2d +# define ROUTINE_NFD lbc_nfd_2d_ext +# include "lbc_nfd_ext_generic.h90" +# undef ROUTINE_NFD +# undef DIM_2d + ! + ! !== 3D array and array of 3D pointer ==! + ! +# define DIM_3d +# define ROUTINE_NFD lbc_nfd_3d +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_3d_ptr +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_3d + ! + ! !== 4D array and array of 4D pointer ==! + ! +# define DIM_4d +# define ROUTINE_NFD lbc_nfd_4d +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_4d_ptr +# include "lbc_nfd_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_4d + ! + ! lbc_nfd_nogather routines + ! + ! !== 2D array and array of 2D pointer ==! + ! +# define DIM_2d +# define ROUTINE_NFD lbc_nfd_nogather_2d +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_nogather_2d_ptr +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_2d + ! + ! !== 3D array and array of 3D pointer ==! + ! +# define DIM_3d +# define ROUTINE_NFD lbc_nfd_nogather_3d +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# define MULTI +# define ROUTINE_NFD lbc_nfd_nogather_3d_ptr +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +# undef MULTI +# undef DIM_3d + ! + ! !== 4D array and array of 4D pointer ==! + ! +# define DIM_4d +# define ROUTINE_NFD lbc_nfd_nogather_4d +# include "lbc_nfd_nogather_generic.h90" +# undef ROUTINE_NFD +!# define MULTI +!# define ROUTINE_NFD lbc_nfd_nogather_4d_ptr +!# include "lbc_nfd_nogather_generic.h90" +!# undef ROUTINE_NFD +!# undef MULTI +# undef DIM_4d + + !!---------------------------------------------------------------------- + + + !!====================================================================== +END MODULE lbcnfd diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/lib_mpp.F90 b/NEMO_4.0.4_surge/src/OCE/LBC/lib_mpp.F90 new file mode 100644 index 0000000..41f6df6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/lib_mpp.F90 @@ -0,0 +1,1303 @@ +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 + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! 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_north : initialisation of north fold + !! mpp_lbc_north_icb : alternative to mpp_nfd for extra outer halo with icebergs + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + ! + PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam + PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free + PUBLIC mpp_ini_north + 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 mppsend, mpprecv ! needed by TAM and ICB routines + PUBLIC mpp_report + PUBLIC tic_tac +#if ! defined key_mpp_mpi + PUBLIC MPI_Wtime +#endif + + !! * 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, mppmin_a_real, mppmin_real + END INTERFACE + INTERFACE mpp_max + MODULE PROCEDURE mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real + END INTERFACE + INTERFACE mpp_sum + MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & + & mppsum_realdd, mppsum_a_realdd + END INTERFACE + INTERFACE mpp_minloc + MODULE PROCEDURE mpp_minloc2d ,mpp_minloc3d + END INTERFACE + INTERFACE mpp_maxloc + MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d + END INTERFACE + + !! ========================= !! + !! MPI variable definition !! + !! ========================= !! +#if defined key_mpp_mpi +!$AGRIF_DO_NOT_TREAT + INCLUDE 'mpif.h' +!$AGRIF_END_DO_NOT_TREAT + LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .TRUE. !: mpp flag +#else + INTEGER, PUBLIC, PARAMETER :: MPI_STATUS_SIZE = 1 + INTEGER, PUBLIC, PARAMETER :: MPI_DOUBLE_PRECISION = 8 + LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag +#endif + + INTEGER, PARAMETER :: nprocmax = 2**10 ! maximun dimension (required to be a power of 2) + + 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 + + ! 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 + + ! 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=128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines + CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_glb !: names of global comm calling routines + CHARACTER(len=128), 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_dttrc = 1 !: copy of top time step # nn_dttrc + 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(wp), 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(wp), DIMENSION(2), PUBLIC :: waiting_time = 0._wp + REAL(wp) , PUBLIC :: compute_time = 0._wp, elapsed_time = 0._wp + + REAL(wp), DIMENSION(:), ALLOCATABLE, SAVE :: tampon ! buffer in case of bsend + + LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms + LOGICAL, PUBLIC :: l_north_nogather = .FALSE. !: internal control of northfold comms + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !!---------------------------------------------------------------------- +#if defined key_mpp_mpi + ! + 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 + +# if defined key_agrif + IF( Agrif_Root() ) THEN + CALL Agrif_MPI_Init(mpi_comm_oce) + ELSE + CALL Agrif_MPI_set_grid_comm(mpi_comm_oce) + ENDIF +# 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) + ! +#else + IF( PRESENT( localComm ) ) mpi_comm_oce = localComm + mppsize = 1 + mpprank = 0 +#endif + 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(in ) :: md_req ! argument for isend + !! + INTEGER :: iflag + !!---------------------------------------------------------------------- + ! +#if defined key_mpp_mpi + CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) +#endif + ! + END SUBROUTINE mppsend + + + 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 + !!---------------------------------------------------------------------- + ! +#if defined key_mpp_mpi + ! 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 ) +#endif + ! + END SUBROUTINE mpprecv + + + 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 +#if defined key_mpp_mpi + CALL mpi_gather( ptab, itaille, mpi_double_precision, pio, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) +#else + pio(:,:,1) = ptab(:,:) +#endif + ! + 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 + ! +#if defined key_mpp_mpi + CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & + & mpi_double_precision, kp , mpi_comm_oce, ierror ) +#else + ptab(:,:) = pio(:,:,1) +#endif + ! + 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(wp), 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(wp), ALLOCATABLE, DIMENSION(:) :: ytmp + !!---------------------------------------------------------------------- +#if defined key_mpp_mpi + 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 +# if defined key_mpi2 + IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ierr ) + ndelayid(idvar) = MPI_REQUEST_NULL + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) +# else + CALL mpi_iallreduce( y_in(:), todelay(idvar)%y1d(:), isz, MPI_DOUBLE_COMPLEX, mpi_sumdd, ilocalcomm, ndelayid(idvar), ierr ) +# endif +#else + pout(:) = REAL(y_in(:), wp) +#endif + + 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 + !!---------------------------------------------------------------------- + +#if defined key_mpp_mpi + 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 ? +# if defined key_mpi2 + IF( ln_timing ) CALL tic_tac( .TRUE., ld_global = .TRUE.) + CALL mpi_allreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ierr ) + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) +# else + CALL mpi_iallreduce( p_in(:), todelay(idvar)%z1d(:), isz, MPI_DOUBLE_PRECISION, mpi_max, ilocalcomm, ndelayid(idvar), ierr ) +# endif +#else + pout(:) = p_in(:) +#endif + + 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 defined key_mpp_mpi + 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 +#endif + END SUBROUTINE mpp_delay_rcv + + + !!---------------------------------------------------------------------- + !! *** mppmax_a_int, mppmax_int, mppmax_a_real, mppmax_real *** + !! + !!---------------------------------------------------------------------- + !! +# define OPERATION_MAX +# define INTEGER_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef INTEGER_TYPE +! +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmax_real +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmax_a_real +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_MAX + !!---------------------------------------------------------------------- + !! *** mppmin_a_int, mppmin_int, mppmin_a_real, mppmin_real *** + !! + !!---------------------------------------------------------------------- + !! +# define OPERATION_MIN +# define INTEGER_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef INTEGER_TYPE +! +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppmin_real +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppmin_a_real +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_MIN + + !!---------------------------------------------------------------------- + !! *** mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real *** + !! + !! Global sum of 1D array or a variable (integer, real or complex) + !!---------------------------------------------------------------------- + !! +# define OPERATION_SUM +# define INTEGER_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_int +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef INTEGER_TYPE +! +# define REAL_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_real +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_real +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef REAL_TYPE +# undef OPERATION_SUM + +# define OPERATION_SUM_DD +# define COMPLEX_TYPE +# define DIM_0d +# define ROUTINE_ALLREDUCE mppsum_realdd +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_0d +# define DIM_1d +# define ROUTINE_ALLREDUCE mppsum_a_realdd +# include "mpp_allreduce_generic.h90" +# undef ROUTINE_ALLREDUCE +# undef DIM_1d +# undef COMPLEX_TYPE +# undef OPERATION_SUM_DD + + !!---------------------------------------------------------------------- + !! *** mpp_minloc2d, mpp_minloc3d, mpp_maxloc2d, mpp_maxloc3d + !! + !!---------------------------------------------------------------------- + !! +# define OPERATION_MINLOC +# define DIM_2d +# define ROUTINE_LOC mpp_minloc2d +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_minloc3d +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MINLOC + +# define OPERATION_MAXLOC +# define DIM_2d +# define ROUTINE_LOC mpp_maxloc2d +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_2d +# define DIM_3d +# define ROUTINE_LOC mpp_maxloc3d +# include "mpp_loc_generic.h90" +# undef ROUTINE_LOC +# undef DIM_3d +# undef OPERATION_MAXLOC + + SUBROUTINE mppsync() + !!---------------------------------------------------------------------- + !! *** routine mppsync *** + !! + !! ** Purpose : Massively parallel processors, synchroneous + !! + !!----------------------------------------------------------------------- + INTEGER :: ierror + !!----------------------------------------------------------------------- + ! +#if defined key_mpp_mpi + CALL mpi_barrier( mpi_comm_oce, ierror ) +#endif + ! + 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 + !!---------------------------------------------------------------------- + ll_abort = .FALSE. + IF( PRESENT(ld_abort) ) ll_abort = ld_abort + ! +#if defined key_mpp_mpi + IF(ll_abort) THEN + CALL mpi_abort( MPI_COMM_WORLD ) + ELSE + CALL mppsync + CALL mpi_finalize( info ) + ENDIF +#endif + IF( ll_abort ) STOP 123 + ! + END SUBROUTINE mppstop + + + SUBROUTINE mpp_comm_free( kcom ) + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kcom + !! + INTEGER :: ierr + !!---------------------------------------------------------------------- + ! +#if defined key_mpp_mpi + CALL MPI_COMM_FREE(kcom, ierr) +#endif + ! + 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 + !!---------------------------------------------------------------------- +#if defined key_mpp_mpi + !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - ngrp_world : ', ngrp_world + !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - mpi_comm_world : ', mpi_comm_world + !-$$ WRITE (numout,*) 'mpp_ini_znl ', nproc, ' - 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 ', nproc, ' - 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 ', nproc, ' - 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 ', nproc, ' - 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 ', nproc, ' - 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 ', nproc, ' - 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 ', nproc, ' - 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) +#endif + + END SUBROUTINE mpp_ini_znl + + + SUBROUTINE mpp_ini_north + !!---------------------------------------------------------------------- + !! *** routine mpp_ini_north *** + !! + !! ** 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 + !! njmppmax = njmpp for northern procs + !! 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 + !!---------------------------------------------------------------------- + ! +#if defined key_mpp_mpi + njmppmax = MAXVAL( njmppt ) + ! + ! Look for how many procs on the northern boundary + ndim_rank_north = 0 + DO jjproc = 1, jpnij + IF( njmppt(jjproc) == njmppmax ) 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, jpnij + IF ( njmppt(ji) == njmppmax ) THEN + ii=ii+1 + nrank_north(ii)=ji-1 + 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 ) + ! +#endif + END SUBROUTINE mpp_ini_north + + + 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(wp), DIMENSION(ilen), INTENT(in) :: ydda + COMPLEX(wp), DIMENSION(ilen), INTENT(inout) :: yddb + ! + REAL(wp) :: 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),wp ) + 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 + !!---------------------------------------------------------------------- +#if defined key_mpp_mpi + ! + 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 + IF( ncom_dttrc /= 1 ) CALL ctl_stop( 'STOP', 'mpp_report, ncom_dttrc /= 1 not coded...' ) + 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(ncom_rec_max)) + 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 +#endif + END SUBROUTINE mpp_report + + + SUBROUTINE tic_tac (ld_tic, ld_global) + + LOGICAL, INTENT(IN) :: ld_tic + LOGICAL, OPTIONAL, INTENT(IN) :: ld_global + REAL(wp), DIMENSION(2), SAVE :: tic_wt + REAL(wp), SAVE :: tic_ct = 0._wp + INTEGER :: ii +#if defined key_mpp_mpi + + 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_wp ) 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 +#endif + + END SUBROUTINE tic_tac + +#if ! defined key_mpp_mpi + SUBROUTINE mpi_wait(request, status, ierror) + INTEGER , INTENT(in ) :: request + INTEGER, DIMENSION(MPI_STATUS_SIZE), INTENT( out) :: status + INTEGER , INTENT( out) :: ierror + END SUBROUTINE mpi_wait + + + FUNCTION MPI_Wtime() + REAL(wp) :: MPI_Wtime + MPI_Wtime = -1. + END FUNCTION MPI_Wtime +#endif + + !!---------------------------------------------------------------------- + !! ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 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 + ! + 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 +#if defined key_agrif + IF( .NOT. Agrif_Root() ) clfile = TRIM(Agrif_CFixed())//'_'//TRIM(clfile) + knum=Agrif_Get_Unit() +#else + knum=get_unit() +#endif + 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 < 998) .AND. llopn ) + get_unit = get_unit + 1 + INQUIRE( unit = get_unit, opened = llopn ) + END DO + IF( (get_unit == 999) .AND. llopn ) THEN + CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) + ENDIF + ! + END FUNCTION get_unit + + !!---------------------------------------------------------------------- +END MODULE lib_mpp diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/mpp_allreduce_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_allreduce_generic.h90 new file mode 100644 index 0000000..0f0ddb3 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_allreduce_generic.h90 @@ -0,0 +1,82 @@ +! !== IN: ptab is an array ==! +# if defined REAL_TYPE +# define ARRAY_TYPE(i) REAL(wp) , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) REAL(wp) , ALLOCATABLE :: work(i) +# define MPI_TYPE mpi_double_precision +# 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 , INTENT(inout) :: ARRAY_IN(i) +# define TMP_TYPE(i) COMPLEX , 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_mpp_mpi + ! + 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 ARRAY_TYPE +#undef ARRAY_IN +#undef I_SIZE +#undef MPI_OPERATION +#undef TMP_TYPE +#undef MPI_TYPE diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/mpp_lnk_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_lnk_generic.h90 new file mode 100644 index 0000000..c551c43 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_lnk_generic.h90 @@ -0,0 +1,394 @@ +#if defined MULTI +# define NAT_IN(k) cd_nat(k) +# define SGN_IN(k) psgn(k) +# define F_SIZE(ptab) kfld +# define OPT_K(k) ,ipf +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) +# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) +# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) +# endif +#else +# define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) +# define NAT_IN(k) cd_nat +# define SGN_IN(k) psgn +# define F_SIZE(ptab) 1 +# define OPT_K(k) +# if defined DIM_2d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) SIZE(ptab,4) +# endif +#endif + +#if defined MULTI + SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ihlcom ) + INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays +#else + SUBROUTINE ROUTINE_LNK( cdname, ptab, cd_nat, psgn , kfillmode, pfillval, lsend, lrecv, ihlcom ) +#endif + ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied + CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine + CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points + REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary + 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, DIMENSION(4),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc + INTEGER ,OPTIONAL, INTENT(in ) :: ihlcom ! number of ranks and rows to be communicated + ! + INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: isize, ishift, ishift2 ! local integers + INTEGER :: ireq_we, ireq_ea, ireq_so, ireq_no ! mpi_request id + INTEGER :: ierr + INTEGER :: ifill_we, ifill_ea, ifill_so, ifill_no + INTEGER :: ihl ! number of ranks and rows to be communicated + REAL(wp) :: zland + INTEGER , DIMENSION(MPI_STATUS_SIZE) :: istat ! for mpi_isend + REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_we, zrcv_we, zsnd_ea, zrcv_ea ! east -west & west - east halos + REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zsnd_so, zrcv_so, zsnd_no, zrcv_no ! north-south & south-north halos + LOGICAL :: llsend_we, llsend_ea, llsend_no, llsend_so ! communication send + LOGICAL :: llrecv_we, llrecv_ea, llrecv_no, llrecv_so ! communication receive + LOGICAL :: lldo_nfd ! do north pole folding + !!---------------------------------------------------------------------- + ! + ! ----------------------------------------- ! + ! 0. local variables initialization ! + ! ----------------------------------------- ! + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ipl = L_SIZE(ptab) ! 4th - + ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) + ! + IF( PRESENT(ihlcom) ) THEN ; ihl = ihlcom + ELSE ; ihl = 1 + END IF + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. ) + ! + IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN + llsend_we = lsend(1) ; llsend_ea = lsend(2) ; llsend_so = lsend(3) ; llsend_no = lsend(4) + llrecv_we = lrecv(1) ; llrecv_ea = lrecv(2) ; llrecv_so = lrecv(3) ; llrecv_no = lrecv(4) + ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN + WRITE(ctmp1,*) ' E R R O R : Routine ', cdname, ' is calling lbc_lnk with only one of the two arguments lsend or lrecv' + WRITE(ctmp2,*) ' ========== ' + CALL ctl_stop( ' ', ctmp1, ctmp2, ' ' ) + ELSE ! send and receive with every neighbour + llsend_we = nbondi == 1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini + llsend_ea = nbondi == -1 .OR. nbondi == 0 ! keep for compatibility, should be defined in mppini + llsend_so = nbondj == 1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini + llsend_no = nbondj == -1 .OR. nbondj == 0 ! keep for compatibility, should be defined in mppini + llrecv_we = llsend_we ; llrecv_ea = llsend_ea ; llrecv_so = llsend_so ; llrecv_no = llsend_no + END IF + + + lldo_nfd = npolj /= 0 ! keep for compatibility, should be defined in mppini + + zland = 0._wp ! land filling value: zero by default + IF( PRESENT( pfillval ) ) zland = pfillval ! set land value + + ! define the method we will use to fill the halos in each direction + IF( llrecv_we ) THEN ; ifill_we = jpfillmpi + ELSEIF( l_Iperio ) THEN ; ifill_we = jpfillperio + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_we = kfillmode + ELSE ; ifill_we = jpfillcst + END IF + ! + IF( llrecv_ea ) THEN ; ifill_ea = jpfillmpi + ELSEIF( l_Iperio ) THEN ; ifill_ea = jpfillperio + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_ea = kfillmode + ELSE ; ifill_ea = jpfillcst + END IF + ! + IF( llrecv_so ) THEN ; ifill_so = jpfillmpi + ELSEIF( l_Jperio ) THEN ; ifill_so = jpfillperio + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_so = kfillmode + ELSE ; ifill_so = jpfillcst + END IF + ! + IF( llrecv_no ) THEN ; ifill_no = jpfillmpi + ELSEIF( l_Jperio ) THEN ; ifill_no = jpfillperio + ELSEIF( PRESENT(kfillmode) ) THEN ; ifill_no = kfillmode + ELSE ; ifill_no = jpfillcst + END IF + ! +#if defined PRINT_CAUTION + ! + ! ================================================================================== ! + ! CAUTION: semi-column notation is often impossible because of the cpp preprocessing ! + ! ================================================================================== ! + ! +#endif + ! + ! -------------------------------------------------- ! + ! 1. Do east and west MPI exchange if needed ! + ! -------------------------------------------------- ! + ! + ! Must exchange the whole column (from 1 to jpj) to get the corners if we have no south/north neighbourg + isize = ihl * jpj * ipk * ipl * ipf + ! + ! Allocate local temporary arrays to be sent/received. Fill arrays to be sent + IF( llsend_we ) ALLOCATE( zsnd_we(ihl,jpj,ipk,ipl,ipf) ) + IF( llsend_ea ) ALLOCATE( zsnd_ea(ihl,jpj,ipk,ipl,ipf) ) + IF( llrecv_we ) ALLOCATE( zrcv_we(ihl,jpj,ipk,ipl,ipf) ) + IF( llrecv_ea ) ALLOCATE( zrcv_ea(ihl,jpj,ipk,ipl,ipf) ) + ! + IF( llsend_we ) THEN ! copy western side of the inner mpi domain in local temporary array to be sent by MPI + ishift = ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + zsnd_we(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! ihl + 1 -> 2*ihl + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + ! + IF(llsend_ea ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI + ishift = jpi - 2 * ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + zsnd_ea(ji,jj,jk,jl,jf) = ARRAY_IN(ishift+ji,jj,jk,jl,jf) ! jpi - 2*ihl + 1 -> jpi - ihl + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + ! non-blocking send of the western/eastern side using local temporary arrays + IF( llsend_we ) CALL mppsend( 1, zsnd_we(1,1,1,1,1), isize, nowe, ireq_we ) + IF( llsend_ea ) CALL mppsend( 2, zsnd_ea(1,1,1,1,1), isize, noea, ireq_ea ) + ! blocking receive of the western/eastern halo in local temporary arrays + IF( llrecv_we ) CALL mpprecv( 2, zrcv_we(1,1,1,1,1), isize, nowe ) + IF( llrecv_ea ) CALL mpprecv( 1, zrcv_ea(1,1,1,1,1), isize, noea ) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! + ! ----------------------------------- ! + ! 2. Fill east and west halos ! + ! ----------------------------------- ! + ! + ! 2.1 fill weastern halo + ! ---------------------- + ! ishift = 0 ! fill halo from ji = 1 to ihl + SELECT CASE ( ifill_we ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! use data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_we(ji,jj,jk,jl,jf) ! 1 -> ihl + END DO; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use east-weast periodicity + ishift2 = jpi - 2 * ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) + END DO; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ! number of arrays to be treated + IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point + DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ihl+1,jj,jk,jl,jf) + END DO ; END DO ; END DO ; END DO + ENDIF + END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ! number of arrays to be treated + IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point + DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ji,jj,jk,jl,jf) = zland + END DO; END DO ; END DO ; END DO + ENDIF + END DO + END SELECT + ! + ! 2.2 fill eastern halo + ! --------------------- + ishift = jpi - ihl ! fill halo from ji = jpi-ihl+1 to jpi + SELECT CASE ( ifill_ea ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! use data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zrcv_ea(ji,jj,jk,jl,jf) ! jpi - ihl + 1 -> jpi + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use east-weast periodicity + ishift2 = ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift2+ji,jj,jk,jl,jf) + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, jpj ; DO ji = 1, ihl + ARRAY_IN(ishift+ji,jj,jk,jl,jf) = ARRAY_IN(ishift,jj,jk,jl,jf) + 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, jpj ; DO ji = 1, ihl + ARRAY_IN(ishift+ji,jj,jk,jl,jf) = zland + END DO; END DO ; END DO ; END DO ; END DO + END SELECT + ! + ! ------------------------------- ! + ! 3. north fold treatment ! + ! ------------------------------- ! + ! + ! do it before south directions so concerned processes can do it without waiting for the comm with the sourthern neighbor + ! + IF( lldo_nfd .AND. ifill_no /= jpfillnothing ) THEN + ! + SELECT CASE ( jpni ) + CASE ( 1 ) ; CALL lbc_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! only 1 northern proc, no mpp + CASE DEFAULT ; CALL mpp_nfd( ptab, NAT_IN(:), SGN_IN(:) OPT_K(:) ) ! for all northern procs. + END SELECT + ! + ifill_no = jpfillnothing ! force to do nothing for the northern halo as we just done the north pole folding + ! + ENDIF + ! + ! ---------------------------------------------------- ! + ! 4. Do north and south MPI exchange if needed ! + ! ---------------------------------------------------- ! + ! + IF( llsend_so ) ALLOCATE( zsnd_so(jpi,ihl,ipk,ipl,ipf) ) + IF( llsend_no ) ALLOCATE( zsnd_no(jpi,ihl,ipk,ipl,ipf) ) + IF( llrecv_so ) ALLOCATE( zrcv_so(jpi,ihl,ipk,ipl,ipf) ) + IF( llrecv_no ) ALLOCATE( zrcv_no(jpi,ihl,ipk,ipl,ipf) ) + ! + isize = jpi * ihl * ipk * ipl * ipf + + ! allocate local temporary arrays to be sent/received. Fill arrays to be sent + IF( llsend_so ) THEN ! copy sourhern side of the inner mpi domain in local temporary array to be sent by MPI + ishift = ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + zsnd_so(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! ihl+1 -> 2*ihl + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + ! + IF( llsend_no ) THEN ! copy eastern side of the inner mpi domain in local temporary array to be sent by MPI + ishift = jpj - 2 * ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + zsnd_no(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift+jj,jk,jl,jf) ! jpj-2*ihl+1 -> jpj-ihl + END DO ; END DO ; END DO ; END DO ; END DO + ENDIF + ! + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + ! non-blocking send of the southern/northern side + IF( llsend_so ) CALL mppsend( 3, zsnd_so(1,1,1,1,1), isize, noso, ireq_so ) + IF( llsend_no ) CALL mppsend( 4, zsnd_no(1,1,1,1,1), isize, nono, ireq_no ) + ! blocking receive of the southern/northern halo + IF( llrecv_so ) CALL mpprecv( 4, zrcv_so(1,1,1,1,1), isize, noso ) + IF( llrecv_no ) CALL mpprecv( 3, zrcv_no(1,1,1,1,1), isize, nono ) + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! ------------------------------------- ! + ! 5. Fill south and north halos ! + ! ------------------------------------- ! + ! + ! 5.1 fill southern halo + ! ---------------------- + ! ishift = 0 ! fill halo from jj = 1 to ihl + SELECT CASE ( ifill_so ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! use data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,jj,jk,jl,jf) = zrcv_so(ji,jj,jk,jl,jf) ! 1 -> ihl + END DO; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use north-south periodicity + ishift2 = jpj - 2 * ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) + END DO; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ! number of arrays to be treated + IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point + DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,jj,jk,jl,jf) = ARRAY_IN(ji,ihl+1,jk,jl,jf) + END DO ; END DO ; END DO ; END DO + ENDIF + END DO + CASE ( jpfillcst ) ! filling with constant value + DO jf = 1, ipf ! number of arrays to be treated + IF( .NOT. NAT_IN(jf) == 'F' ) THEN ! do nothing for F point + DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,jj,jk,jl,jf) = zland + END DO; END DO ; END DO ; END DO + ENDIF + END DO + END SELECT + ! + ! 5.2 fill northern halo + ! ---------------------- + ishift = jpj - ihl ! fill halo from jj = jpj-ihl+1 to jpj + SELECT CASE ( ifill_no ) + CASE ( jpfillnothing ) ! no filling + CASE ( jpfillmpi ) ! use data received by MPI + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zrcv_no(ji,jj,jk,jl,jf) ! jpj-ihl+1 -> jpj + END DO ; END DO ; END DO ; END DO ; END DO + CASE ( jpfillperio ) ! use north-south periodicity + ishift2 = ihl + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift2+jj,jk,jl,jf) + END DO; END DO ; END DO ; END DO ; END DO + CASE ( jpfillcopy ) ! filling with inner domain values + DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,ishift+jj,jk,jl,jf) = ARRAY_IN(ji,ishift,jk,jl,jf) + 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, ihl ; DO ji = 1, jpi + ARRAY_IN(ji,ishift+jj,jk,jl,jf) = zland + END DO; END DO ; END DO ; END DO ; END DO + END SELECT + ! + ! -------------------------------------------- ! + ! 6. deallocate local temporary arrays ! + ! -------------------------------------------- ! + ! + IF( llsend_we ) THEN + CALL mpi_wait(ireq_we, istat, ierr ) + DEALLOCATE( zsnd_we ) + ENDIF + IF( llsend_ea ) THEN + CALL mpi_wait(ireq_ea, istat, ierr ) + DEALLOCATE( zsnd_ea ) + ENDIF + IF( llsend_so ) THEN + CALL mpi_wait(ireq_so, istat, ierr ) + DEALLOCATE( zsnd_so ) + ENDIF + IF( llsend_no ) THEN + CALL mpi_wait(ireq_no, istat, ierr ) + DEALLOCATE( zsnd_no ) + ENDIF + ! + IF( llrecv_we ) DEALLOCATE( zrcv_we ) + IF( llrecv_ea ) DEALLOCATE( zrcv_ea ) + IF( llrecv_so ) DEALLOCATE( zrcv_so ) + IF( llrecv_no ) DEALLOCATE( zrcv_no ) + ! + END SUBROUTINE ROUTINE_LNK + +#undef ARRAY_TYPE +#undef NAT_IN +#undef SGN_IN +#undef ARRAY_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE +#undef OPT_K diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/mpp_loc_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_loc_generic.h90 new file mode 100644 index 0000000..237a08f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_loc_generic.h90 @@ -0,0 +1,108 @@ + !== IN: ptab is an array ==! +# define ARRAY_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: ARRAY_IN(i,j,k) +# define MASK_TYPE(i,j,k) REAL(wp) , INTENT(in ) :: MASK_IN(i,j,k) +# if defined DIM_2d +# define ARRAY_IN(i,j,k) ptab(i,j) +# define MASK_IN(i,j,k) pmask(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) pmask(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, pmask, pmin, kindex ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which loctrans operation is applied + MASK_TYPE(:,:,:) ! local mask + REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab + INDEX_TYPE(:) ! index of minimum in global frame + ! + INTEGER :: ierror, ii, idim + INTEGER :: index0 + REAL(wp) :: zmin ! local minimum + INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs + REAL(wp), DIMENSION(2,1) :: zain, zaout + !!----------------------------------------------------------------------- + ! + IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ld_glb = .TRUE. ) + ! + idim = SIZE(kindex) + ! + IF ( ALL(MASK_IN(:,:,:) /= 1._wp) ) THEN + ! special case for land processors + zmin = ERRVAL(zmin) + index0 = 0 + ELSE + ALLOCATE ( ilocs(idim) ) + ! + ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) == 1._wp ) + 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 + END IF + zain(1,:) = zmin + zain(2,:) = REAL(index0, wp) + ! + IF( ln_timing ) CALL tic_tac(.TRUE., ld_global = .TRUE.) +#if defined key_mpp_mpi + CALL MPI_ALLREDUCE( zain, zaout, 1, MPI_2DOUBLE_PRECISION, MPI_OPERATION ,MPI_COMM_OCE, ierror) +#else + zaout(:,:) = zain(:,:) +#endif + IF( ln_timing ) CALL tic_tac(.FALSE., ld_global = .TRUE.) + ! + 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 + + END SUBROUTINE ROUTINE_LOC + +#undef ARRAY_TYPE +#undef MAX_TYPE +#undef ARRAY_IN +#undef MASK_IN +#undef K_SIZE +#undef MPI_OPERATION +#undef LOC_OPERATION +#undef INDEX_TYPE +#undef ERRVAL diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/mpp_nfd_generic.h90 b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_nfd_generic.h90 new file mode 100644 index 0000000..6e2f802 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/mpp_nfd_generic.h90 @@ -0,0 +1,307 @@ +#if defined MULTI +# define NAT_IN(k) cd_nat(k) +# define SGN_IN(k) psgn(k) +# define F_SIZE(ptab) kfld +# define LBC_ARG (jf) +# if defined DIM_2d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_2D) , INTENT(inout) :: ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt2d(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_3D) , INTENT(inout) :: ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt3d(i,j,k) +# define K_SIZE(ptab) SIZE(ptab(1)%pt3d,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_TYPE(i,j,k,l,f) TYPE(PTR_4D) , INTENT(inout) :: ptab(f) +# define ARRAY_IN(i,j,k,l,f) ptab(f)%pt4d(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab(1)%pt4d,3) +# define L_SIZE(ptab) SIZE(ptab(1)%pt4d,4) +# endif +#else +! !== IN: ptab is an array ==! +# define ARRAY_TYPE(i,j,k,l,f) REAL(wp) , INTENT(inout) :: ARRAY_IN(i,j,k,l,f) +# define NAT_IN(k) cd_nat +# define SGN_IN(k) psgn +# define F_SIZE(ptab) 1 +# define LBC_ARG +# if defined DIM_2d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j) +# define K_SIZE(ptab) 1 +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_3d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) 1 +# endif +# if defined DIM_4d +# define ARRAY_IN(i,j,k,l,f) ptab(i,j,k,l) +# define K_SIZE(ptab) SIZE(ptab,3) +# define L_SIZE(ptab) SIZE(ptab,4) +# endif +#endif + + SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld ) + !!---------------------------------------------------------------------- + ARRAY_TYPE(:,:,:,:,:) ! array or pointer of arrays on which the boundary condition is applied + CHARACTER(len=1) , INTENT(in ) :: NAT_IN(:) ! nature of array grid-points + REAL(wp) , INTENT(in ) :: SGN_IN(:) ! sign used across the north fold boundary + INTEGER, OPTIONAL, INTENT(in ) :: kfld ! number of pt3d arrays + ! + INTEGER :: ji, jj, jk, jl, jh, jf, jr ! dummy loop indices + INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array + INTEGER :: imigr, iihom, ijhom ! local integers + INTEGER :: ierr, ibuffsize, ilci, ildi, ilei, iilb + INTEGER :: ij, iproc + INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf ! for mpi_isend when avoiding mpi_allgather + INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather + INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for mpi_isend when avoiding mpi_allgather + ! ! Workspace for message transfers avoiding mpi_allgather + INTEGER :: ipf_j ! sum of lines for all multi fields + INTEGER :: js ! counter + INTEGER, DIMENSION(:,:), ALLOCATABLE :: jj_s ! position of sent lines + INTEGER, DIMENSION(:), ALLOCATABLE :: ipj_s ! number of sent lines + REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl + REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: ztab, ztabr + REAL(wp), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk + REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthgloio + !!---------------------------------------------------------------------- + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ipl = L_SIZE(ptab) ! 4th - + ipf = F_SIZE(ptab) ! 5th - use in "multi" case (array of pointers) + ! + IF( l_north_nogather ) THEN !== no allgather exchanges ==! + + ALLOCATE(ipj_s(ipf)) + + ipj = 2 ! Max 2nd dimension of message transfers (last two j-line only) + ipj_s(:) = 1 ! Real 2nd dimension of message transfers (depending on perf requirement) + ! by default, only one line is exchanged + + ALLOCATE( jj_s(ipf,2) ) + + ! re-define number of exchanged lines : + ! must be two during the first two time steps + ! to correct possible incoherent values on North fold lines from restart + + !!!!!!!!! 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. + + ! Two lines update (slower but necessary to avoid different values ion identical grid points + IF ( l_full_nf_update .OR. & ! if coupling fields + ( ncom_stp == nit000 .AND. .NOT. ln_rstart ) ) & ! at first time step, if not restart + ipj_s(:) = 2 + + ! Index of modifying lines in input + DO jf = 1, ipf ! Loop over the number of arrays to be processed + ! + SELECT CASE ( npolj ) + ! + CASE ( 3, 4 ) ! * North fold T-point pivot + ! + SELECT CASE ( NAT_IN(jf) ) + ! + CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point + jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 + CASE ( 'V' , 'F' ) ! V-, F-point + jj_s(jf,1) = nlcj - 3 ; jj_s(jf,2) = nlcj - 2 + END SELECT + ! + CASE ( 5, 6 ) ! * North fold F-point pivot + SELECT CASE ( NAT_IN(jf) ) + ! + CASE ( 'T' , 'W' ,'U' ) ! T-, U-, W-point + jj_s(jf,1) = nlcj - 1 + ipj_s(jf) = 1 ! need only one line anyway + CASE ( 'V' , 'F' ) ! V-, F-point + jj_s(jf,1) = nlcj - 2 ; jj_s(jf,2) = nlcj - 1 + END SELECT + ! + END SELECT + ! + ENDDO + ! + ipf_j = sum (ipj_s(:)) ! Total number of lines to be exchanged + ! + ALLOCATE( znorthloc(jpimax,ipf_j,ipk,ipl,1) ) + ! + js = 0 + DO jf = 1, ipf ! Loop over the number of arrays to be processed + DO jj = 1, ipj_s(jf) + js = js + 1 + DO jl = 1, ipl + DO jk = 1, ipk + znorthloc(1:jpi,js,jk,jl,1) = ARRAY_IN(1:jpi,jj_s(jf,jj),jk,jl,jf) + END DO + END DO + END DO + END DO + ! + ibuffsize = jpimax * ipf_j * ipk * ipl + ! + ALLOCATE( zfoldwk(jpimax,ipf_j,ipk,ipl,1) ) + ALLOCATE( ztabr(jpimax*jpmaxngh,ipj,ipk,ipl,ipf) ) + ! when some processors of the north fold are suppressed, + ! values of ztab* arrays corresponding to these suppressed domain won't be defined + ! and we need a default definition to 0. + ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding + IF ( jpni*jpnj /= jpnij ) ztabr(:,:,:,:,:) = 0._wp + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + ! + DO jr = 1, nsndto + IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN + CALL mppsend( 5, znorthloc, ibuffsize, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) ) + ENDIF + END DO + ! + DO jr = 1,nsndto + iproc = nfipproc(isendto(jr),jpnj) + IF(iproc /= -1) THEN + iilb = nimppt(iproc+1) + ilci = nlcit (iproc+1) + ildi = nldit (iproc+1) + ilei = nleit (iproc+1) + IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column + IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column + iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) + ENDIF + IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN + CALL mpprecv(5, zfoldwk, ibuffsize, iproc) + js = 0 + DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) + js = js + 1 + DO jl = 1, ipl + DO jk = 1, ipk + DO ji = ildi, ilei + ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,js,jk,jl,1) + END DO + END DO + END DO + END DO; END DO + ELSE IF( iproc == narea-1 ) THEN + DO jf = 1, ipf ; DO jj = 1, ipj_s(jf) + DO jl = 1, ipl + DO jk = 1, ipk + DO ji = ildi, ilei + ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,jj_s(jf,jj),jk,jl,jf) + END DO + END DO + END DO + END DO; END DO + ENDIF + END DO + DO jr = 1,nsndto + IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN + CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err ) + ENDIF + END DO + ! + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + ! North fold boundary condition + ! + DO jf = 1, ipf + CALL lbc_nfd_nogather( ARRAY_IN(:,:,:,:,jf), ztabr(:,1:ipj_s(jf),:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) + END DO + ! + DEALLOCATE( zfoldwk, ztabr, jj_s, ipj_s ) + ! + ELSE !== allgather exchanges ==! + ! + ipj = 4 ! 2nd dimension of message transfers (last j-lines) + ! + ALLOCATE( znorthloc(jpimax,ipj,ipk,ipl,ipf) ) + ! + DO jf = 1, ipf ! put in znorthloc the last ipj j-lines of ptab + DO jl = 1, ipl + DO jk = 1, ipk + DO jj = nlcj - ipj +1, nlcj + ij = jj - nlcj + ipj + znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf) + END DO + END DO + END DO + END DO + ! + ibuffsize = jpimax * ipj * ipk * ipl * ipf + ! + ALLOCATE( ztab (jpiglo,ipj,ipk,ipl,ipf ) ) + ALLOCATE( znorthgloio(jpimax,ipj,ipk,ipl,ipf,jpni) ) + ! + ! when some processors of the north fold are suppressed, + ! values of ztab* arrays corresponding to these suppressed domain won't be defined + ! and we need a default definition to 0. + ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding + IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:) = 0._wp + ! + ! start waiting time measurement + IF( ln_timing ) CALL tic_tac(.TRUE.) + CALL MPI_ALLGATHER( znorthloc , ibuffsize, MPI_DOUBLE_PRECISION, & + & znorthgloio, ibuffsize, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) + ! + ! stop waiting time measurement + IF( ln_timing ) CALL tic_tac(.FALSE.) + ! + DO jr = 1, ndim_rank_north ! recover the global north array + iproc = nrank_north(jr) + 1 + iilb = nimppt(iproc) + ilci = nlcit (iproc) + ildi = nldit (iproc) + ilei = nleit (iproc) + IF( iilb == 1 ) ildi = 1 ! e-w boundary already done -> force to take 1st column + IF( iilb + ilci - 1 == jpiglo ) ilei = ilci ! e-w boundary already done -> force to take last column + DO jf = 1, ipf + DO jl = 1, ipl + DO jk = 1, ipk + DO jj = 1, ipj + DO ji = ildi, ilei + ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr) + END DO + END DO + END DO + END DO + END DO + END DO + DO jf = 1, ipf + CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG ) ! North fold boundary condition + END DO + ! + DO jf = 1, ipf + DO jl = 1, ipl + DO jk = 1, ipk + DO jj = nlcj-ipj+1, nlcj ! Scatter back to ARRAY_IN + ij = jj - nlcj + ipj + DO ji= 1, nlci + ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf) + END DO + END DO + END DO + END DO + END DO + ! + ! + DEALLOCATE( ztab ) + DEALLOCATE( znorthgloio ) + ENDIF + ! + DEALLOCATE( znorthloc ) + ! + END SUBROUTINE ROUTINE_NFD + +#undef ARRAY_TYPE +#undef NAT_IN +#undef SGN_IN +#undef ARRAY_IN +#undef K_SIZE +#undef L_SIZE +#undef F_SIZE +#undef LBC_ARG diff --git a/NEMO_4.0.4_surge/src/OCE/LBC/mppini.F90 b/NEMO_4.0.4_surge/src/OCE/LBC/mppini.F90 new file mode 100644 index 0000000..abd39b3 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LBC/mppini.F90 @@ -0,0 +1,1306 @@ +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 mpp_init_nfdcom + !! 3. ! 2013-06 (I. Epicoco, S. Mocavero, CMCC) mpp_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 + !! mpp_init_mask : Read global bathymetric information to facilitate land suppression + !! mpp_init_ioipsl : IOIPSL initialization in mpp + !! mpp_init_partition: Calculate MPP domain decomposition + !! factorise : Calculate the factors of the no. of MPI processes + !! mpp_init_nfdcom : Setup for north fold exchanges with explicit point-to-point messaging + !!---------------------------------------------------------------------- + USE dom_oce ! ocean space and time domain + USE bdy_oce ! open BounDarY + ! + USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! 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 opa.F90 + + INTEGER :: numbot = -1 ! 'bottom_level' local logical unit + INTEGER :: numbdy = -1 ! 'bdy_msk' local logical unit + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +#if ! defined key_mpp_mpi + !!---------------------------------------------------------------------- + !! Default option : shared memory computing + !!---------------------------------------------------------------------- + + SUBROUTINE mpp_init + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init *** + !! + !! ** Purpose : Lay out the global domain over processors. + !! + !! ** Method : Shared memory computing, set the local processor + !! variables to the value of the global domain + !!---------------------------------------------------------------------- + ! + jpimax = jpiglo + jpjmax = jpjglo + jpi = jpiglo + jpj = jpjglo + jpk = jpkglo + jpim1 = jpi-1 ! inner domain indices + jpjm1 = jpj-1 ! " " + jpkm1 = MAX( 1, jpk-1 ) ! " " + jpij = jpi*jpj + jpni = 1 + jpnj = 1 + jpnij = jpni*jpnj + nimpp = 1 ! + njmpp = 1 + nlci = jpi + nlcj = jpj + nldi = 1 + nldj = 1 + nlei = jpi + nlej = jpj + nbondi = 2 + nbondj = 2 + nidom = FLIO_DOM_NONE + npolj = 0 + IF( jperio == 3 .OR. jperio == 4 ) npolj = 3 + IF( jperio == 5 .OR. jperio == 6 ) npolj = 5 + l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) + l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) + ! + ! Set flags to detect global domain edges for AGRIF + l_Westedge = .true. ; l_Eastedge = .true. ; l_Northedge = .true.; l_Southedge = .true. + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp_init : NO massively parallel processing' + WRITE(numout,*) '~~~~~~~~ ' + WRITE(numout,*) ' l_Iperio = ', l_Iperio, ' l_Jperio = ', l_Jperio + WRITE(numout,*) ' npolj = ', npolj , ' njmpp = ', njmpp + ENDIF + ! + IF( jpni /= 1 .OR. jpnj /= 1 .OR. jpnij /= 1 ) & + CALL ctl_stop( 'mpp_init: equality jpni = jpnj = jpnij = 1 is not satisfied', & + & 'the domain is lay out for distributed memory computing!' ) + ! + END SUBROUTINE mpp_init + +#else + !!---------------------------------------------------------------------- + !! 'key_mpp_mpi' 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 + !! Type : jperio global periodic condition + !! + !! ** Action : - set domain parameters + !! nimpp : longitudinal index + !! njmpp : latitudinal index + !! narea : number for local area + !! nlci : first dimension + !! nlcj : second dimension + !! nbondi : mark for "east-west local boundary" + !! nbondj : mark for "north-south local boundary" + !! nproc : number for local processor + !! noea : number for local neighboring processor + !! nowe : number for local neighboring processor + !! noso : number for local neighboring processor + !! nono : number for local neighboring processor + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jn, jproc, jarea ! dummy loop indices + INTEGER :: inijmin + INTEGER :: i2add + INTEGER :: inum ! local logical unit + INTEGER :: idir, ifreq, icont ! local integers + INTEGER :: ii, il1, ili, imil ! - - + INTEGER :: ij, il2, ilj, ijm1 ! - - + INTEGER :: iino, ijno, iiso, ijso ! - - + INTEGER :: iiea, ijea, iiwe, ijwe ! - - + INTEGER :: iarea0 ! - - + INTEGER :: ierr, ios ! + INTEGER :: inbi, inbj, iimax, ijmax, icnt1, icnt2 + LOGICAL :: llbest, llauto + LOGICAL :: llwrtlay + LOGICAL :: ln_listonly + INTEGER, ALLOCATABLE, DIMENSION(:) :: iin, ii_nono, ii_noea ! 1D workspace + INTEGER, ALLOCATABLE, DIMENSION(:) :: ijn, ii_noso, ii_nowe ! - - + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci, ibondi, ipproc ! 2D workspace + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj, ibondj, ipolj ! - - + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilei, ildi, iono, ioea ! - - + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilej, ildj, ioso, iowe ! - - + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: llisoce ! - - + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lliswest, lliseast, llisnorth, llissouth ! - - + 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, ln_nnogather, ln_listonly + !!---------------------------------------------------------------------- + ! + llwrtlay = lwp .OR. ln_ctl .OR. sn_cfctl%l_layout + ! + ! 0. read namelists parameters + ! ----------------------------------- + ! + REWIND( numnam_ref ) ! Namelist nammpp in reference namelist + READ ( numnam_ref, nammpp, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nammpp in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist nammpp in confguration namelist + READ ( numnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' ) + ! + 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 + ENDIF + ! + IF(lwm) WRITE( numond, nammpp ) + + ! do we need to take into account bdy_msk? + REWIND( numnam_ref ) ! Namelist nambdy in reference namelist : BDY + READ ( numnam_ref, nambdy, IOSTAT = ios, ERR = 903) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambdy in reference namelist (mppini)' ) + REWIND( numnam_cfg ) ! Namelist nambdy in configuration namelist : BDY + 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 mpp_init_bestpartition( MAX(mppsize,jpni*jpnj), ldlist = .TRUE. ) ! must be done by all core + ! + ! 1. Dimension arrays for subdomains + ! ----------------------------------- + ! + ! If dimensions of processor 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,*) 'mpp_init:' + WRITE(numout,*) '~~~~~~~~ ' + WRITE(numout,*) + ENDIF + IF( jpni < 1 .OR. jpnj < 1 ) THEN + CALL mpp_init_bestpartition( mppsize, jpni, jpnj ) ! best mpi decomposition for mppsize mpi processes + llauto = .TRUE. + llbest = .TRUE. + ELSE + llauto = .FALSE. + CALL mpp_init_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_basic_decomposition( jpni, jpnj, jpimax, jpjmax ) + ! largest subdomain size for mpi decoposition inbi*inbj given by mpp_init_bestpartition + CALL mpp_basic_decomposition( 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_init_isoce( jpni, jpnj, 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 mpp_init_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 mpp_init_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) + + IF( numbot /= -1 ) CALL iom_close( numbot ) + IF( numbdy /= -1 ) CALL iom_close( numbdy ) + + ALLOCATE( nfiimpp(jpni,jpnj), nfipproc(jpni,jpnj), nfilcit(jpni,jpnj) , & + & nimppt(jpnij) , ibonit(jpnij) , nlcit(jpnij) , nlcjt(jpnij) , & + & njmppt(jpnij) , ibonjt(jpnij) , nldit(jpnij) , nldjt(jpnij) , & + & nleit(jpnij) , nlejt(jpnij) , & + & iin(jpnij), ii_nono(jpnij), ii_noea(jpnij), & + & ijn(jpnij), ii_noso(jpnij), ii_nowe(jpnij), & + & iimppt(jpni,jpnj), ilci(jpni,jpnj), ibondi(jpni,jpnj), ipproc(jpni,jpnj), & + & ijmppt(jpni,jpnj), ilcj(jpni,jpnj), ibondj(jpni,jpnj), ipolj(jpni,jpnj), & + & ilei(jpni,jpnj), ildi(jpni,jpnj), iono(jpni,jpnj), ioea(jpni,jpnj), & + & ilej(jpni,jpnj), ildj(jpni,jpnj), ioso(jpni,jpnj), iowe(jpni,jpnj), & +#if defined key_agrif + lliswest(jpni,jpnj), lliseast(jpni,jpnj), & + & llisnorth(jpni,jpnj),llissouth(jpni,jpnj), & +#endif + & STAT=ierr ) + CALL mpp_sum( 'mppini', ierr ) + IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_init: unable to allocate standard ocean arrays' ) + +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN ! AGRIF children: specific setting (cf. agrif_user.F90) + IF( jpiglo /= nbcellsx + 2 + 2*nbghostcells ) & + CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpiglo == nbcellsx + 2 + 2*nbghostcells' ) + IF( jpjglo /= nbcellsy + 2 + 2*nbghostcells ) & + CALL ctl_stop( 'STOP', 'mpp_init: Agrif children requires jpjglo == nbcellsy + 2 + 2*nbghostcells' ) + IF( ln_use_jattr ) CALL ctl_stop( 'STOP', 'mpp_init:Agrif children requires ln_use_jattr = .false. ' ) + ENDIF + lliswest(:,:) = .false. ; lliseast(:,:) = .false. ; llisnorth(:,:) = .false. ; llissouth(:,:) = .false. +#endif + ! + ! 2. Index arrays for subdomains + ! ----------------------------------- + ! + nreci = 2 * nn_hls + nrecj = 2 * nn_hls + CALL mpp_basic_decomposition( jpni, jpnj, jpimax, jpjmax, iimppt, ijmppt, ilci, ilcj ) + nfiimpp(:,:) = iimppt(:,:) + nfilcit(:,:) = ilci(:,:) + ! + 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,*) + WRITE(numout,*) ' sum ilci(i,1) = ', sum(ilci(:,1)), ' jpiglo = ', jpiglo + WRITE(numout,*) ' sum ilcj(1,j) = ', sum(ilcj(1,:)), ' jpjglo = ', jpjglo + ENDIF + + ! 3. Subdomain description in the Regular Case + ! -------------------------------------------- + ! specific cases where there is no communication -> must do the periodicity by itself + ! Warning: because of potential land-area suppression, do not use nbond[ij] == 2 + l_Iperio = jpni == 1 .AND. (jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7) + l_Jperio = jpnj == 1 .AND. (jperio == 2 .OR. jperio == 7) + + DO jarea = 1, jpni*jpnj + ! + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,jpni) + ij = 1 + iarea0/jpni + ili = ilci(ii,ij) + ilj = ilcj(ii,ij) + ibondi(ii,ij) = 0 ! default: has e-w neighbours + IF( ii == 1 ) ibondi(ii,ij) = -1 ! first column, has only e neighbour + IF( ii == jpni ) ibondi(ii,ij) = 1 ! last column, has only w neighbour + IF( jpni == 1 ) ibondi(ii,ij) = 2 ! has no e-w neighbour + ibondj(ii,ij) = 0 ! default: has n-s neighbours + IF( ij == 1 ) ibondj(ii,ij) = -1 ! first row, has only n neighbour + IF( ij == jpnj ) ibondj(ii,ij) = 1 ! last row, has only s neighbour + IF( jpnj == 1 ) ibondj(ii,ij) = 2 ! has no n-s neighbour + + ! Subdomain neighbors (get their zone number): default definition + ioso(ii,ij) = iarea0 - jpni + iowe(ii,ij) = iarea0 - 1 + ioea(ii,ij) = iarea0 + 1 + iono(ii,ij) = iarea0 + jpni + ildi(ii,ij) = 1 + nn_hls + ilei(ii,ij) = ili - nn_hls + ildj(ii,ij) = 1 + nn_hls + ilej(ii,ij) = ilj - nn_hls + + ! East-West periodicity: change ibondi, ioea, iowe + IF( jperio == 1 .OR. jperio == 4 .OR. jperio == 6 .OR. jperio == 7 ) THEN + IF( jpni /= 1 ) ibondi(ii,ij) = 0 ! redefine: all have e-w neighbours + IF( ii == 1 ) iowe(ii,ij) = iarea0 + (jpni-1) ! redefine: first column, address of w neighbour + IF( ii == jpni ) ioea(ii,ij) = iarea0 - (jpni-1) ! redefine: last column, address of e neighbour + ENDIF + + ! Simple North-South periodicity: change ibondj, ioso, iono + IF( jperio == 2 .OR. jperio == 7 ) THEN + IF( jpnj /= 1 ) ibondj(ii,ij) = 0 ! redefine: all have n-s neighbours + IF( ij == 1 ) ioso(ii,ij) = iarea0 + jpni * (jpnj-1) ! redefine: first row, address of s neighbour + IF( ij == jpnj ) iono(ii,ij) = iarea0 - jpni * (jpnj-1) ! redefine: last row, address of n neighbour + ENDIF + + ! North fold: define ipolj, change iono. Warning: we do not change ibondj... + ipolj(ii,ij) = 0 + IF( jperio == 3 .OR. jperio == 4 ) THEN + ijm1 = jpni*(jpnj-1) + imil = ijm1+(jpni+1)/2 + IF( jarea > ijm1 ) ipolj(ii,ij) = 3 + IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 4 + IF( ipolj(ii,ij) == 3 ) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour + ENDIF + IF( jperio == 5 .OR. jperio == 6 ) THEN + ijm1 = jpni*(jpnj-1) + imil = ijm1+(jpni+1)/2 + IF( jarea > ijm1) ipolj(ii,ij) = 5 + IF( MOD(jpni,2) == 1 .AND. jarea == imil ) ipolj(ii,ij) = 6 + IF( ipolj(ii,ij) == 5) iono(ii,ij) = jpni*jpnj-jarea+ijm1 ! MPI rank of northern neighbour + ENDIF + ! +#if defined key_agrif + IF ((ibondi(ii,ij) == 1).OR.(ibondi(ii,ij) == 2)) lliseast(ii,ij) = .true. ! east + IF ((ibondi(ii,ij) == -1).OR.(ibondi(ii,ij) == 2)) lliswest(ii,ij) = .true. ! west + IF ((ibondj(ii,ij) == 1).OR.(ibondj(ii,ij) == 2)) llisnorth(ii,ij) = .true. ! north + IF ((ibondj(ii,ij) == -1).OR.(ibondj(ii,ij) == 2)) llissouth(ii,ij) = .true. ! south +#endif + END DO + ! 4. deal with land subdomains + ! ---------------------------- + ! + ! specify which subdomains are oce subdomains; other are land subdomains + ipproc(:,:) = -1 + icont = -1 + DO jarea = 1, jpni*jpnj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,jpni) + ij = 1 + iarea0/jpni + IF( llisoce(ii,ij) ) THEN + icont = icont + 1 + ipproc(ii,ij) = icont + iin(icont+1) = ii + ijn(icont+1) = ij + ENDIF + END DO + ! if needed add some land subdomains to reach jpnij active subdomains + i2add = jpnij - inijmin + DO jarea = 1, jpni*jpnj + iarea0 = jarea - 1 + ii = 1 + MOD(iarea0,jpni) + ij = 1 + iarea0/jpni + IF( .NOT. llisoce(ii,ij) .AND. i2add > 0 ) THEN + icont = icont + 1 + ipproc(ii,ij) = icont + iin(icont+1) = ii + ijn(icont+1) = ij + i2add = i2add - 1 + ENDIF + END DO + nfipproc(:,:) = ipproc(:,:) + + ! neighbour treatment: change ibondi, ibondj if next to a land zone + DO jarea = 1, jpni*jpnj + ii = 1 + MOD( jarea-1 , jpni ) + ij = 1 + (jarea-1) / jpni + ! land-only area with an active n neigbour + IF ( ipproc(ii,ij) == -1 .AND. 0 <= iono(ii,ij) .AND. iono(ii,ij) <= jpni*jpnj-1 ) THEN + iino = 1 + MOD( iono(ii,ij) , jpni ) ! ii index of this n neigbour + ijno = 1 + iono(ii,ij) / jpni ! ij index of this n neigbour + ! In case of north fold exchange: I am the n neigbour of my n neigbour!! (#1057) + ! --> for northern neighbours of northern row processors (in case of north-fold) + ! need to reverse the LOGICAL direction of communication + idir = 1 ! we are indeed the s neigbour of this n neigbour + IF( ij == jpnj .AND. ijno == jpnj ) idir = -1 ! both are on the last row, we are in fact the n neigbour + IF( ibondj(iino,ijno) == idir ) ibondj(iino,ijno) = 2 ! this n neigbour had only a s/n neigbour -> no more + IF( ibondj(iino,ijno) == 0 ) ibondj(iino,ijno) = -idir ! this n neigbour had both, n-s neighbours -> keep 1 + ENDIF + ! land-only area with an active s neigbour + IF( ipproc(ii,ij) == -1 .AND. 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= jpni*jpnj-1 ) THEN + iiso = 1 + MOD( ioso(ii,ij) , jpni ) ! ii index of this s neigbour + ijso = 1 + ioso(ii,ij) / jpni ! ij index of this s neigbour + IF( ibondj(iiso,ijso) == -1 ) ibondj(iiso,ijso) = 2 ! this s neigbour had only a n neigbour -> no more neigbour + IF( ibondj(iiso,ijso) == 0 ) ibondj(iiso,ijso) = 1 ! this s neigbour had both, n-s neighbours -> keep s neigbour + ENDIF + ! land-only area with an active e neigbour + IF( ipproc(ii,ij) == -1 .AND. 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= jpni*jpnj-1 ) THEN + iiea = 1 + MOD( ioea(ii,ij) , jpni ) ! ii index of this e neigbour + ijea = 1 + ioea(ii,ij) / jpni ! ij index of this e neigbour + IF( ibondi(iiea,ijea) == 1 ) ibondi(iiea,ijea) = 2 ! this e neigbour had only a w neigbour -> no more neigbour + IF( ibondi(iiea,ijea) == 0 ) ibondi(iiea,ijea) = -1 ! this e neigbour had both, e-w neighbours -> keep e neigbour + ENDIF + ! land-only area with an active w neigbour + IF( ipproc(ii,ij) == -1 .AND. 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= jpni*jpnj-1) THEN + iiwe = 1 + MOD( iowe(ii,ij) , jpni ) ! ii index of this w neigbour + ijwe = 1 + iowe(ii,ij) / jpni ! ij index of this w neigbour + IF( ibondi(iiwe,ijwe) == -1 ) ibondi(iiwe,ijwe) = 2 ! this w neigbour had only a e neigbour -> no more neigbour + IF( ibondi(iiwe,ijwe) == 0 ) ibondi(iiwe,ijwe) = 1 ! this w neigbour had both, e-w neighbours -> keep w neigbour + ENDIF + END DO + + ! Update il[de][ij] according to modified ibond[ij] + ! ---------------------- + DO jproc = 1, jpnij + ii = iin(jproc) + ij = ijn(jproc) + IF( ibondi(ii,ij) == -1 .OR. ibondi(ii,ij) == 2 ) ildi(ii,ij) = 1 + IF( ibondi(ii,ij) == 1 .OR. ibondi(ii,ij) == 2 ) ilei(ii,ij) = ilci(ii,ij) + IF( ibondj(ii,ij) == -1 .OR. ibondj(ii,ij) == 2 ) ildj(ii,ij) = 1 + IF( ibondj(ii,ij) == 1 .OR. ibondj(ii,ij) == 2 ) ilej(ii,ij) = ilcj(ii,ij) + END DO + + ! 5. Subdomain print + ! ------------------ + IF(lwp) THEN + 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, (ilci(ji,jj),ilcj(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 + + ! just to save nono etc for all proc + ! warning ii*ij (zone) /= nproc (processors)! + ! ioso = zone number, ii_noso = proc number + ii_noso(:) = -1 + ii_nono(:) = -1 + ii_noea(:) = -1 + ii_nowe(:) = -1 + DO jproc = 1, jpnij + ii = iin(jproc) + ij = ijn(jproc) + IF( 0 <= ioso(ii,ij) .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN + iiso = 1 + MOD( ioso(ii,ij) , jpni ) + ijso = 1 + ioso(ii,ij) / jpni + ii_noso(jproc) = ipproc(iiso,ijso) + ENDIF + IF( 0 <= iowe(ii,ij) .AND. iowe(ii,ij) <= (jpni*jpnj-1) ) THEN + iiwe = 1 + MOD( iowe(ii,ij) , jpni ) + ijwe = 1 + iowe(ii,ij) / jpni + ii_nowe(jproc) = ipproc(iiwe,ijwe) + ENDIF + IF( 0 <= ioea(ii,ij) .AND. ioea(ii,ij) <= (jpni*jpnj-1) ) THEN + iiea = 1 + MOD( ioea(ii,ij) , jpni ) + ijea = 1 + ioea(ii,ij) / jpni + ii_noea(jproc)= ipproc(iiea,ijea) + ENDIF + IF( 0 <= iono(ii,ij) .AND. iono(ii,ij) <= (jpni*jpnj-1) ) THEN + iino = 1 + MOD( iono(ii,ij) , jpni ) + ijno = 1 + iono(ii,ij) / jpni + ii_nono(jproc)= ipproc(iino,ijno) + ENDIF + END DO + + ! 6. Change processor name + ! ------------------------ + ii = iin(narea) + ij = ijn(narea) + ! + ! set default neighbours + noso = ii_noso(narea) + nowe = ii_nowe(narea) + noea = ii_noea(narea) + nono = ii_nono(narea) + nlci = ilci(ii,ij) + nldi = ildi(ii,ij) + nlei = ilei(ii,ij) + nlcj = ilcj(ii,ij) + nldj = ildj(ii,ij) + nlej = ilej(ii,ij) + nbondi = ibondi(ii,ij) + nbondj = ibondj(ii,ij) + nimpp = iimppt(ii,ij) + njmpp = ijmppt(ii,ij) + jpi = nlci + jpj = nlcj + jpk = jpkglo ! third dim +#if defined key_agrif + ! simple trick to use same vertical grid as parent but different number of levels: + ! Save maximum number of levels in jpkglo, then define all vertical grids with this number. + ! Suppress once vertical online interpolation is ok +!!$ IF(.NOT.Agrif_Root()) jpkglo = Agrif_Parent( jpkglo ) + l_Westedge = lliswest(ii,ij) + l_Eastedge = lliseast(ii,ij) + l_Northedge = llisnorth(ii,ij) + l_Southedge = llissouth(ii,ij) +#endif + jpim1 = jpi-1 ! inner domain indices + jpjm1 = jpj-1 ! " " + jpkm1 = MAX( 1, jpk-1 ) ! " " + jpij = jpi*jpj ! jpi x j + DO jproc = 1, jpnij + ii = iin(jproc) + ij = ijn(jproc) + nlcit(jproc) = ilci(ii,ij) + nldit(jproc) = ildi(ii,ij) + nleit(jproc) = ilei(ii,ij) + nlcjt(jproc) = ilcj(ii,ij) + nldjt(jproc) = ildj(ii,ij) + nlejt(jproc) = ilej(ii,ij) + ibonit(jproc) = ibondi(ii,ij) + ibonjt(jproc) = ibondj(ii,ij) + nimppt(jproc) = iimppt(ii,ij) + njmppt(jproc) = ijmppt(ii,ij) + END DO + + ! 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,'(6i8,a,3i8,a)') jpnij,jpimax,jpjmax,jpk,jpiglo,jpjglo,& + & ' ( local: ',narea,jpi,jpj,' )' + WRITE(inum,'(a)') 'nproc nlci nlcj nldi nldj nlei nlej nimp njmp nono noso nowe noea nbondi nbondj ' + + DO jproc = 1, jpnij + WRITE(inum,'(13i5,2i7)') jproc-1, nlcit (jproc), nlcjt (jproc), & + & nldit (jproc), nldjt (jproc), & + & nleit (jproc), nlejt (jproc), & + & nimppt (jproc), njmppt (jproc), & + & ii_nono(jproc), ii_noso(jproc), & + & ii_nowe(jproc), ii_noea(jproc), & + & ibonit (jproc), ibonjt (jproc) + END DO + END IF + + ! ! north fold parameter + ! Defined npolj, either 0, 3 , 4 , 5 , 6 + ! In this case the important thing is that npolj /= 0 + ! Because if we go through these line it is because jpni >1 and thus + ! we must use lbcnorthmpp, which tests only npolj =0 or npolj /= 0 + npolj = 0 + ij = ijn(narea) + IF( jperio == 3 .OR. jperio == 4 ) THEN + IF( ij == jpnj ) npolj = 3 + ENDIF + IF( jperio == 5 .OR. jperio == 6 ) THEN + IF( ij == jpnj ) npolj = 5 + ENDIF + ! + nproc = narea-1 + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' resulting internal parameters : ' + WRITE(numout,*) ' nproc = ', nproc + WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea + WRITE(numout,*) ' nono = ', nono , ' noso = ', noso + WRITE(numout,*) ' nbondi = ', nbondi + WRITE(numout,*) ' nbondj = ', nbondj + WRITE(numout,*) ' npolj = ', npolj + WRITE(numout,*) ' l_Iperio = ', l_Iperio + WRITE(numout,*) ' l_Jperio = ', l_Jperio + WRITE(numout,*) ' nlci = ', nlci + WRITE(numout,*) ' nlcj = ', nlcj + WRITE(numout,*) ' nimpp = ', nimpp + WRITE(numout,*) ' njmpp = ', njmpp + WRITE(numout,*) ' nreci = ', nreci + WRITE(numout,*) ' nrecj = ', nrecj + WRITE(numout,*) ' nn_hls = ', nn_hls + ENDIF + + ! ! Prepare mpp north fold + IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN + CALL mpp_ini_north + IF (lwp) THEN + WRITE(numout,*) + WRITE(numout,*) ' ==>>> North fold boundary prepared for jpni >1' + ! additional prints in layout.dat + ENDIF + IF (llwrtlay) THEN + WRITE(inum,*) + WRITE(inum,*) + WRITE(inum,*) 'number of subdomains located along the north fold : ', ndim_rank_north + WRITE(inum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north + DO jproc = 1, ndim_rank_north, 5 + WRITE(inum,*) nrank_north( jproc:MINVAL( (/jproc+4,ndim_rank_north/) ) ) + END DO + ENDIF + ENDIF + ! + CALL mpp_init_ioipsl ! Prepare NetCDF output file (if necessary) + ! + IF (( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ).AND.( ln_nnogather )) THEN + CALL mpp_init_nfdcom ! northfold neighbour lists + IF (llwrtlay) THEN + WRITE(inum,*) + WRITE(inum,*) + WRITE(inum,*) 'north fold exchanges with explicit point-to-point messaging :' + WRITE(inum,*) 'nfsloop : ', nfsloop + WRITE(inum,*) 'nfeloop : ', nfeloop + WRITE(inum,*) 'nsndto : ', nsndto + WRITE(inum,*) 'isendto : ', isendto + ENDIF + ENDIF + ! + IF (llwrtlay) CLOSE(inum) + ! + DEALLOCATE(iin, ijn, ii_nono, ii_noea, ii_noso, ii_nowe, & + & iimppt, ijmppt, ibondi, ibondj, ipproc, ipolj, & + & ilci, ilcj, ilei, ilej, ildi, ildj, & + & iono, ioea, ioso, iowe, llisoce) +#if defined key_agrif + DEALLOCATE(lliswest, lliseast, llisnorth, llissouth) +#endif + ! + END SUBROUTINE mpp_init + + + SUBROUTINE mpp_basic_decomposition( knbi, knbj, kimax, kjmax, kimppt, kjmppt, klci, klcj) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_basic_decomposition *** + !! + !! ** 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 ) :: 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 :: iresti, irestj, irm, ijpjmin + INTEGER :: ireci, irecj + !!---------------------------------------------------------------------- + ! +#if defined key_nemocice_decomp + kimax = ( nx_global+2-2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim. + kjmax = ( ny_global+2-2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim. +#else + kimax = ( jpiglo - 2*nn_hls + (knbi-1) ) / knbi + 2*nn_hls ! first dim. + kjmax = ( jpjglo - 2*nn_hls + (knbj-1) ) / knbj + 2*nn_hls ! second dim. +#endif + 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 jpiglo,jpjglo + ! The subdomains are squares lesser than or equal to the global + ! dimensions divided by the number of processors minus the overlap array. + ! + ireci = 2 * nn_hls + irecj = 2 * nn_hls + iresti = 1 + MOD( jpiglo - ireci -1 , knbi ) + irestj = 1 + MOD( jpjglo - irecj -1 , knbj ) + ! + ! Need to use kimax and kjmax here since jpi and jpj not yet defined +#if defined key_nemocice_decomp + ! Change padding to be consistent with CICE + klci(1:knbi-1 ,:) = kimax + klci(knbi ,:) = jpiglo - (knbi - 1) * (kimax - nreci) + klcj(:, 1:knbj-1) = kjmax + klcj(:, knbj) = jpjglo - (knbj - 1) * (kjmax - nrecj) +#else + klci(1:iresti ,:) = kimax + klci(iresti+1:knbi ,:) = kimax-1 + IF( MINVAL(klci) < 3 ) THEN + WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpi must be >= 3' + WRITE(ctmp2,*) ' We have ', MINVAL(klci) + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF + IF( jperio == 3 .OR. jperio == 4 .OR. jperio == 5 .OR. jperio == 6 ) THEN + ! minimize the size of the last row to compensate for the north pole folding coast + IF( jperio == 3 .OR. jperio == 4 ) ijpjmin = 5 ! V and F folding involves line jpj-3 that must not be south boundary + IF( jperio == 5 .OR. jperio == 6 ) ijpjmin = 4 ! V and F folding involves line jpj-2 that must not be south boundary + 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(:, 1:irestj) = kjmax + klcj(:, irestj+1:knbj-1) = kjmax-1 + ELSE + ijpjmin = 3 + klcj(:, 1:irestj) = kjmax + klcj(:, irestj+1:knbj) = kjmax-1 + ENDIF + IF( MINVAL(klcj) < ijpjmin ) THEN + WRITE(ctmp1,*) ' mpp_basic_decomposition: minimum value of jpj must be >= ', ijpjmin + WRITE(ctmp2,*) ' We have ', MINVAL(klcj) + CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) + ENDIF +#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) - ireci + 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) - irecj + END DO + END DO + ENDIF + + END SUBROUTINE mpp_basic_decomposition + + + SUBROUTINE mpp_init_bestpartition( knbij, knbi, knbj, knbcnt, ldlist ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init_bestpartition *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: knbij ! total number if 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 :: 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 + iszjref = jpiglo*jpjglo+1 + ! + ! 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 +#if defined key_nemocice_decomp + iszitst = ( nx_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. +#else + iszitst = ( jpiglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls +#endif + IF( iszitst < isziref ) THEN + isziref = iszitst + inbimax = inbimax + 1 + inbi0(inbimax) = ji + iszi0(inbimax) = isziref + ENDIF +#if defined key_nemocice_decomp + iszjtst = ( ny_global+2-2*nn_hls + (ji-1) ) / ji + 2*nn_hls ! first dim. +#else + iszjtst = ( jpjglo - 2*nn_hls + (ji-1) ) / ji + 2*nn_hls +#endif + IF( iszjtst < iszjref ) THEN + iszjref = iszjtst + inbjmax = inbjmax + 1 + inbj0(inbjmax) = ji + iszj0(inbjmax) = iszjref + ENDIF + END DO + + ! 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) + END IF + END DO + END DO + DEALLOCATE( inbi0, inbj0, iszi0, iszj0 ) + DEALLOCATE( llmsk2d ) + + ALLOCATE( inbij1(isz1), iszij1(isz1) ) + inbij1(:) = inbi1(:) * inbj1(:) + iszij1(:) = iszi1(:) * iszj1(:) + + ! if therr 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 + 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,*) + END IF + ji = isz0 ! initialization with the largest value + ALLOCATE( llisoce(inbi0(ji), inbj0(ji)) ) + CALL mpp_init_isoce( inbi0(ji), inbj0(ji), 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_init_isoce( inbi0(ji), inbj0(ji), 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 + END IF + 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_init_isoce( inbi0(ii), inbj0(ii), 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 mpp_init_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 jpiglo) 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, jpjglo/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 = jpjglo / iproc ! width of the stripe to read + IF( iarea < MOD(jpjglo,iproc) ) ijsz = ijsz + 1 + ijstr = iarea*(jpjglo/iproc) + MIN(iarea, MOD(jpjglo,iproc)) + 1 ! starting j position of the reading + ! + ALLOCATE( lloce(jpiglo, ijsz) ) ! allocate the strip + CALL mpp_init_readbot_strip( ijstr, 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( jpiglo*jpjglo - inboce, wp ) / REAL( jpiglo*jpjglo, wp ) + ! + END SUBROUTINE mpp_init_landprop + + + SUBROUTINE mpp_init_isoce( knbi, knbj, ldisoce ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init_nboce *** + !! + !! ** Purpose : check for a mpi domain decomposition knbi x knbj which + !! subdomains contain at least 1 ocean point + !! + !! ** Method : read knbj strips (of length jpiglo) of the land-sea mask + !!---------------------------------------------------------------------- + INTEGER, INTENT(in ) :: knbi, knbj ! domain decomposition + LOGICAL, DIMENSION(knbi,knbj), INTENT( out) :: ldisoce ! .true. if a sub domain constains 1 ocean point + ! + INTEGER, DIMENSION(knbi,knbj) :: inboce ! number oce oce pint in each mpi subdomain + INTEGER, DIMENSION(knbi*knbj) :: inboce_1d + INTEGER :: idiv, iimax, ijmax, iarea + INTEGER :: ji, jn + LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: lloce ! lloce(i,j) = .true. if the point (i,j) is ocean + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iimppt, ilci + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ijmppt, ilcj + !!---------------------------------------------------------------------- + ! do nothing if there is no land-sea mask + IF( numbot == -1 .AND. numbdy == -1 ) THEN + ldisoce(:,:) = .TRUE. + RETURN + ENDIF + + ! we want to read knbj strips of the land-sea mask. -> pick up knbj processes every idiv processes starting at 1 + IF ( knbj == 1 ) THEN ; idiv = mppsize + ELSE IF ( mppsize < knbj ) THEN ; idiv = 1 + ELSE ; idiv = ( mppsize - 1 ) / ( knbj - 1 ) + ENDIF + inboce(:,:) = 0 ! default no ocean point found + + DO jn = 0, (knbj-1)/mppsize ! if mppsize < knbj : more strips than mpi processes (because of potential land domains) + ! + iarea = (narea-1)/idiv + jn * mppsize ! involed process number (starting counting at 0) + IF( MOD( narea-1, idiv ) == 0 .AND. iarea < knbj ) THEN ! beware idiv can be = to 1 + ! + ALLOCATE( iimppt(knbi,knbj), ijmppt(knbi,knbj), ilci(knbi,knbj), ilcj(knbi,knbj) ) + CALL mpp_basic_decomposition( knbi, knbj, iimax, ijmax, iimppt, ijmppt, ilci, ilcj ) + ! + ALLOCATE( lloce(jpiglo, ilcj(1,iarea+1)) ) ! allocate the strip + CALL mpp_init_readbot_strip( ijmppt(1,iarea+1), ilcj(1,iarea+1), lloce ) ! read the strip + DO ji = 1, knbi + inboce(ji,iarea+1) = COUNT( lloce(iimppt(ji,1):iimppt(ji,1)+ilci(ji,1)-1,:) ) ! number of ocean point in subdomain + END DO + ! + DEALLOCATE(lloce) + DEALLOCATE(iimppt, ijmppt, ilci, ilcj) + ! + ENDIF + END DO + + inboce_1d = RESHAPE(inboce, (/ knbi*knbj /)) + CALL mpp_sum( 'mppini', inboce_1d ) + inboce = RESHAPE(inboce_1d, (/knbi, knbj/)) + ldisoce(:,:) = inboce(:,:) /= 0 + ! + END SUBROUTINE mpp_init_isoce + + + SUBROUTINE mpp_init_readbot_strip( kjstr, kjcnt, ldoce ) + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_init_readbot_strip *** + !! + !! ** 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 (jpiglo,...) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kjstr ! starting j position of the reading + INTEGER , INTENT(in ) :: kjcnt ! number of lines to read + LOGICAL, DIMENSION(jpiglo,kjcnt), INTENT( out) :: ldoce ! ldoce(i,j) = .true. if the point (i,j) is ocean + ! + INTEGER :: inumsave ! local logical unit + REAL(wp), DIMENSION(jpiglo,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 = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) ) + ELSE + zbot(:,:) = 1. ! 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 = (/1,kjstr/), kcount = (/jpiglo, kjcnt/) ) + zbot(:,:) = zbot(:,:) * zbdy(:,:) + ENDIF + ! + ldoce(:,:) = zbot(:,:) > 0. + numout = inumsave + ! + END SUBROUTINE mpp_init_readbot_strip + + + SUBROUTINE mpp_init_ioipsl + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_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(1) = jpiglo + iglo(2) = jpjglo + iloc(1) = nlci + iloc(2) = nlcj + iabsf(1) = nimppt(narea) + iabsf(2) = njmppt(narea) + iabsl(:) = iabsf(:) + iloc(:) - 1 + ihals(1) = nldi - 1 + ihals(2) = nldj - 1 + ihale(1) = nlci - nlei + ihale(2) = nlcj - nlej + idid(1) = 1 + idid(2) = 2 + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'mpp_init_ioipsl : iloc = ', iloc (1), iloc (2) + WRITE(numout,*) '~~~~~~~~~~~~~~~ iabsf = ', iabsf(1), iabsf(2) + WRITE(numout,*) ' ihals = ', ihals(1), ihals(2) + WRITE(numout,*) ' ihale = ', ihale(1), ihale(2) + ENDIF + ! + CALL flio_dom_set ( jpnij, nproc, idid, iglo, iloc, iabsf, iabsl, ihals, ihale, 'BOX', nidom) + ! + END SUBROUTINE mpp_init_ioipsl + + + SUBROUTINE mpp_init_nfdcom + !!---------------------------------------------------------------------- + !! *** ROUTINE mpp_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) + !!---------------------------------------------------------------------- + INTEGER :: sxM, dxM, sxT, dxT, jn + INTEGER :: njmppmax + !!---------------------------------------------------------------------- + ! + njmppmax = MAXVAL( njmppt ) + ! + !initializes the north-fold communication variables + isendto(:) = 0 + nsndto = 0 + ! + IF ( njmpp == njmppmax ) THEN ! if I am a process in the north + ! + !sxM is the first point (in the global domain) needed to compute the north-fold for the current process + sxM = jpiglo - nimppt(narea) - nlcit(narea) + 1 + !dxM is the last point (in the global domain) needed to compute the north-fold for the current process + dxM = jpiglo - nimppt(narea) + 2 + ! + ! loop over the other north-fold processes to find the processes + ! managing the points belonging to the sxT-dxT range + ! + DO jn = 1, jpni + ! + sxT = nfiimpp(jn, jpnj) ! sxT = 1st point (in the global domain) of the jn process + dxT = nfiimpp(jn, jpnj) + nfilcit(jn, jpnj) - 1 ! dxT = last point (in the global domain) of the jn process + ! + IF ( sxT < sxM .AND. sxM < dxT ) THEN + nsndto = nsndto + 1 + isendto(nsndto) = jn + ELSEIF( sxM <= sxT .AND. dxM >= dxT ) THEN + nsndto = nsndto + 1 + isendto(nsndto) = jn + ELSEIF( dxM < dxT .AND. sxT < dxM ) THEN + nsndto = nsndto + 1 + isendto(nsndto) = jn + ENDIF + ! + END DO + nfsloop = 1 + nfeloop = nlci + DO jn = 2,jpni-1 + IF( nfipproc(jn,jpnj) == (narea - 1) ) THEN + IF( nfipproc(jn-1,jpnj) == -1 ) nfsloop = nldi + IF( nfipproc(jn+1,jpnj) == -1 ) nfeloop = nlei + ENDIF + END DO + ! + ENDIF + l_north_nogather = .TRUE. + ! + END SUBROUTINE mpp_init_nfdcom + + +#endif + + !!====================================================================== +END MODULE mppini diff --git a/NEMO_4.0.4_surge/src/OCE/LDF/ldfc1d_c2d.F90 b/NEMO_4.0.4_surge/src/OCE/LDF/ldfc1d_c2d.F90 new file mode 100644 index 0000000..cb7688c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LDF/ldfc1d_c2d.F90 @@ -0,0 +1,168 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ! pah2 at F-point (zdep2 is an approximation in zps-coord.) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + 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. ) ! Lateral boundary conditions + ! + CASE( 'TRA' ) ! U- and V-points (zdep1 & 2 are an approximation in zps-coord.) + DO jk = jpkm1, 1, -1 + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + 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_multi( 'ldfc1d_c2d', pah1, 'U', 1. , pah2, 'V', 1. ) + ! + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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/NEMO_4.0.4_surge/src/OCE/LDF/ldfdyn.F90 b/NEMO_4.0.4_surge/src/OCE/LDF/ldfdyn.F90 new file mode 100644 index 0000000..234ac82 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LDF/ldfdyn.F90 @@ -0,0 +1,516 @@ +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) + 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) + ! !! 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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.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.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, 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) + READ ( numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namdyn_ldf in reference namelist' ) + + REWIND( numnam_cfg ) + 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,*) ' 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( 'dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)' ) + ! + IF(.NOT.ln_dynldf_OFF ) THEN !== direction ==>> type of operator ==! + 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( 'dyn_ldf_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_data, 'ahmt_2d', ahmt(:,:,1) ) + CALL iom_get ( inum, jpdom_data, 'ahmf_2d', ahmf(:,:,1) ) + 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_data, 'ahmt_3d', ahmt ) + CALL iom_get ( inum, jpdom_data, 'ahmf_3d', ahmf ) + 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 = 1, jpj ! Set local gridscale values + DO ji = 1, jpi + 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 ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) + zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) + 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 + END DO + END DO + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + zu2pv2_ij_p1 = ub(ji ,jj+1,jk) * ub(ji ,jj+1,jk) + vb(ji+1,jj ,jk) * vb(ji+1,jj ,jk) + zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) + zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) + 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) + END DO + END DO + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + zu2pv2_ij_p1 = ub(ji ,jj+1,jk) * ub(ji ,jj+1,jk) + vb(ji+1,jj ,jk) * vb(ji+1,jj ,jk) + zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(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_multi( 'ldfdyn', ahmt, 'T', 1., ahmf, 'F', 1. ) + ! + ! + 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 * rdt ) ! 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 = 2, jpjm1 + DO ji = 2, jpim1 + zdb = ( ub(ji,jj,jk) * r1_e2u(ji,jj) - ub(ji-1,jj,jk) * r1_e2u(ji-1,jj) ) * r1_e1t(ji,jj) * e2t(ji,jj) & + & - ( vb(ji,jj,jk) * r1_e1v(ji,jj) - vb(ji,jj-1,jk) * 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 = 1, jpjm1 + DO ji = 1, jpim1 + zdb = ( ub(ji,jj+1,jk) * r1_e1u(ji,jj+1) - ub(ji,jj,jk) * r1_e1u(ji,jj) ) * r1_e2f(ji,jj) * e1f(ji,jj) & + & + ( vb(ji+1,jj,jk) * r1_e2v(ji+1,jj) - vb(ji,jj,jk) * 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_multi( 'ldfdyn', dtensq, 'T', 1. ) ! lbc_lnk on dshesq not needed + ! + DO jk = 1, jpkm1 + ! + DO jj = 2, jpjm1 ! T-point value + DO ji = fs_2, fs_jpim1 + ! + zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) + zu2pv2_ij_m1 = ub(ji-1,jj ,jk) * ub(ji-1,jj ,jk) + vb(ji ,jj-1,jk) * vb(ji ,jj-1,jk) + ! + 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 = 1, jpjm1 ! F-point value + DO ji = 1, fs_jpim1 + ! + zu2pv2_ij_p1 = ub(ji ,jj+1,jk) * ub(ji ,jj+1,jk) + vb(ji+1,jj ,jk) * vb(ji+1,jj ,jk) + zu2pv2_ij = ub(ji ,jj ,jk) * ub(ji ,jj ,jk) + vb(ji ,jj ,jk) * vb(ji ,jj ,jk) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ahmt(ji,jj,jk) = SQRT( r1_8 * esqt(ji,jj) * ahmt(ji,jj,jk) ) + END DO + END DO + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ahmf(ji,jj,jk) = SQRT( r1_8 * esqf(ji,jj) * ahmf(ji,jj,jk) ) + END DO + END DO + END DO + ! + ENDIF + ! + CALL lbc_lnk_multi( 'ldfdyn', ahmt, 'T', 1. , ahmf, 'F', 1. ) + ! + 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/NEMO_4.0.4_surge/src/OCE/LDF/ldfslp.F90 b/NEMO_4.0.4_surge/src/OCE/LDF/ldfslp.F90 new file mode 100644 index 0000000..08d7ea8 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LDF/ldfslp.F90 @@ -0,0 +1,807 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE ldf_slp( kt, prd, pn2 ) + !!---------------------------------------------------------------------- + !! *** 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 + 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 !== i- & j-gradient of density ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, jpim1 + 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 = 1, jpjm1 + DO ji = 1, jpim1 + 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 ) ! 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 !* Slopes at u and v points + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! ! 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_n(ji,jj,jk)* ABS( zau ) ) + zbv = MIN( zbv, - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v_n(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_n(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_n(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_n (ji,jj,jk) + gdept_n (ji+1,jj,jk) ) & + - 2 * MAX( risfdep(ji,jj), risfdep(ji+1,jj) ) - e3u_n(ji,jj,miku(ji,jj)) ) + zdepv = 0.5_wp * ( ( gdept_n (ji,jj,jk) + gdept_n (ji,jj+1,jk) ) & + - 2 * MAX( risfdep(ji,jj), risfdep(ji,jj+1) ) - e3v_n(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_n(ji+1,jj,jk)+gdept_n(ji,jj,jk) ) / MAX( hmlpt(ji,jj), hmlpt(ji+1,jj), 10. ) ) +! zcj = 0.5 * ( gdept_n(ji,jj+1,jk)+gdept_n(ji,jj,jk) ) / 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_multi( 'ldfslp', zwz, 'U', -1., zww, 'V', -1. ) ! lateral boundary conditions + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + DO jj = 2, jpjm1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only + DO ji = 2, jpim1 + 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 + DO jj = 3, jpj-2 ! other rows + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! !* 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_n(ji,jj,jk)* ABS( zai ) ) + zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w_n(ji,jj,jk)* 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_n(ji,jj,jk) - gdepw_n(ji,jj,mikt(ji,jj) ) ) / MAX( hmlp(ji,jj) - gdepw_n(ji,jj,mikt(ji,jj)), 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(ji,jj,jk) / 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_multi( 'ldfslp', zwz, 'T', -1., zww, 'T', -1. ) ! lateral boundary conditions + ! + ! !* horizontal Shapiro filter + DO jk = 2, jpkm1 + DO jj = 2, jpjm1, MAX(1, jpj-3) ! rows jj=2 and =jpjm1 only + DO ji = 2, jpim1 + 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 + DO jj = 3, jpj-2 ! other rows + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_multi( 'ldfslp', uslp , 'U', -1. , vslp , 'V', -1. , wslpi, 'W', -1., wslpj, 'W', -1. ) + + IF(ln_ctl) THEN + CALL prt_ctl(tab3d_1=uslp , clinfo1=' slp - u : ', tab3d_2=vslp, clinfo2=' v : ', kdim=jpk) + CALL prt_ctl(tab3d_1=wslpi, clinfo1=' slp - wi: ', tab3d_2=wslpj, clinfo2=' wj: ', kdim=jpk) + ENDIF + ! + IF( ln_timing ) CALL timing_stop('ldf_slp') + ! + END SUBROUTINE ldf_slp + + + SUBROUTINE ldf_slp_triad ( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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 ! done each pair of triad + DO jj = 1, jpjm1 ! NB: not masked ==> a minimum value is set + DO ji = 1, fs_jpim1 ! vector opt. + zdit = ( tsb(ji+1,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) ! i-gradient of T & S at u-point + zdis = ( tsb(ji+1,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) + zdjt = ( tsb(ji,jj+1,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) ! j-gradient of T & S at v-point + zdjs = ( tsb(ji,jj+1,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) + 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 = 1, jpjm1 + DO ji = 1, jpim1 + 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 ! done each pair of triad + DO jj = 1, jpj ! NB: not masked ==> a minimum value is set + DO ji = 1, jpi ! vector opt. + IF( jk+kp > 1 ) THEN ! k-gradient of T & S a jk+kp + zdkt = ( tsb(ji,jj,jk+kp-1,jp_tem) - tsb(ji,jj,jk+kp,jp_tem) ) + zdks = ( tsb(ji,jj,jk+kp-1,jp_sal) - tsb(ji,jj,jk+kp,jp_sal) ) + 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_n(ji,jj,jk+kp) + zdzrho(ji,jj,jk,kp) = - MIN( - repsln , zdzrho_raw ) ! force zdzrho >= repsln + END DO + END DO + END DO + END DO + ! + DO jj = 1, jpj !== Reciprocal depth of the w-point below ML base ==! + DO ji = 1, jpi + 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_n(ji,jj,jk) + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 + 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_n(ji+1,jj,jk-kp) - gdept_n(ji,jj,jk-kp) ) * r1_e1u(ji,jj) ) * umask(ji,jj,jk) + ze3_e1 = e3w_n(ji+ip,jj,jk-kp) * 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_n(ji,jj+1,jk-kp) - gdept_n(ji,jj,jk-kp) ) / e2v(ji,jj) ) * vmask(ji,jj,jk) + ze3_e2 = e3w_n(ji,jj+jp,jk-kp) / 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ! + ! 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_n(ji+1,jj ,jk) - gdept_n(ji,jj,jk) ) * r1_e1u(ji,jj) + ztj_coord = znot_thru_surface * ( gdept_n(ji ,jj+1,jk) - gdept_n(ji,jj,jk) ) * 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_n(ji+ip,jj ,jk+kp) * r1_e1u(ji,jj) + ze3_e2 = e3w_n(ji ,jj+jp,jk+kp) * 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_n(ji+ip,jj,jk+kp) * 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_n(ji,jj+jp,jk+kp) * 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_n(ji ,jj ,jk ) + zbv = e1e2v(ji ,jj ) * e3v_n(ji ,jj ,jk ) + zbti = e1e2t(ji+ip,jj ) * e3w_n(ji+ip,jj ,jk+kp) + zbtj = e1e2t(ji ,jj+jp) * e3w_n(ji ,jj+jp,jk+kp) + ! + 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. ) ! 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 ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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 ! =1 inside the mixed layer, =0 otherwise + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 2, jpjm1 + DO ji = 2, jpim1 + ! !== 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_n(ji,jj,iku)* ABS( zau ) ) + zbv = MIN( zbv , - z1_slpmax * ABS( zav ) , -7.e+3_wp/e3v_n(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_n(ji,jj,ik)* ABS( zai ) ) + zbj = MIN( zbw , -100._wp* ABS( zaj ) , -7.e+3_wp/e3w_n(ji,jj,ik)* 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_multi( 'ldfslp', uslpml , 'U', -1. , vslpml , 'V', -1. , wslpiml, 'W', -1. , wslpjml, 'W', -1. ) + ! + 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 = fs_2, fs_jpim1 ! vector opt. +! uslp (ji,jj,jk) = - ( gdept_n(ji+1,jj,jk) - gdept_n(ji ,jj ,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk) +! vslp (ji,jj,jk) = - ( gdept_n(ji,jj+1,jk) - gdept_n(ji ,jj ,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk) +! wslpi(ji,jj,jk) = - ( gdepw_n(ji+1,jj,jk) - gdepw_n(ji-1,jj,jk) ) * r1_e1t(ji,jj) * wmask(ji,jj,jk) * 0.5 +! wslpj(ji,jj,jk) = - ( gdepw_n(ji,jj+1,jk) - gdepw_n(ji,jj-1,jk) ) * r1_e2t(ji,jj) * wmask(ji,jj,jk) * 0.5 +! END DO +! END DO +! END DO +! CALL lbc_lnk_multi( '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/NEMO_4.0.4_surge/src/OCE/LDF/ldftra.F90 b/NEMO_4.0.4_surge/src/OCE/LDF/ldftra.F90 new file mode 100644 index 0000000..0762df2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/LDF/ldftra.F90 @@ -0,0 +1,953 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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.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.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 + ! ================================= + ! + REWIND( numnam_ref ) + READ ( numnam_ref, namtra_ldf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_ldf in reference namelist' ) + + REWIND( numnam_cfg ) + 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_ldfeiv .AND. .NOT.( ln_traldf_iso .OR. ln_traldf_triad ) ) & + & CALL ctl_stop( 'ln_ldfeiv=T requires iso-neutral laplacian diffusion' ) + 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_data, 'ahtu_2D', ahtu(:,:,1) ) + CALL iom_get ( inum, jpdom_data, 'ahtv_2D', ahtv(:,:,1) ) + 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_data, 'ahtu_3D', ahtu ) + CALL iom_get ( inum, jpdom_data, 'ahtv_3D', ahtv ) + 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 ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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 ) + 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 ) + 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 = 1, jpj + DO ji = 1, jpi + !!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( ub(:,:,jk) ) * e1u(:,:) * r1_12 ! n.b. ub,vb are masked + ahtv(:,:,jk) = ABS( vb(:,:,jk) ) * 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( ub(:,:,jk) ) * e1u(:,:) * r1_12 ) * e1u(:,:) + ahtv(:,:,jk) = SQRT( ABS( vb(:,:,jk) ) * 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_diffusivity.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.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 + ! + REWIND( numnam_ref ) + READ ( numnam_ref, namtra_eiv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_eiv in reference namelist' ) + ! + REWIND( numnam_cfg ) + 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_aht_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' ) + ! + ! != 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_data, 'aeiu', aeiu(:,:,1) ) + CALL iom_get ( inum, jpdom_data, 'aeiv', aeiv(:,:,1) ) + 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_data, 'aeiu', aeiu ) + CALL iom_get ( inum, jpdom_data, 'aeiv', aeiv ) + 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) + ahtv(:,:,jk) = ahtv(:,:,jk) * vmask(:,:,jk) + END DO + ENDIF + ! + ENDIF + ! + END SUBROUTINE ldf_eiv_init + + + SUBROUTINE ldf_eiv( kt, paei0, paeiu, paeiv ) + !!---------------------------------------------------------------------- + !! *** 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 + REAL(wp) , INTENT(inout) :: 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, zaht, zaht_min, 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 = 2, jpjm1 + DO ji = 2, jpim1 + ! 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_n(ji,jj,jk) + ! 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_n(ji,jj,jk) * 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 = 2, jpjm1 + DO ji = 2, jpim1 + ! 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_n(ji,jj,jk) + ! 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_n(ji,jj,jk) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + CALL lbc_lnk( 'ldftra', zaeiw(:,:), 'W', 1. ) ! lateral boundary condition + ! + DO jj = 2, jpjm1 !== aei at u- and v-points ==! + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_multi( 'ldftra', paeiu(:,:,1), 'U', 1. , paeiv(:,:,1), 'V', 1. ) ! 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, pun, pvn, pwn, cdtype ) + !!---------------------------------------------------------------------- + !! *** 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 : pun, pvn increased by the eiv transport + !!---------------------------------------------------------------------- + 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) + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pun ! in : 3 ocean transport components [m3/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pvn ! out: 3 ocean transport components [m3/s] + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pwn ! 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(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + 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 + + + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + pun(ji,jj,jk) = pun(ji,jj,jk) - ( zpsi_uw(ji,jj,jk) - zpsi_uw(ji,jj,jk+1) ) + pvn(ji,jj,jk) = pvn(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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pwn(ji,jj,jk) = pwn(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 ) + ! + END SUBROUTINE ldf_eiv_trp + + + SUBROUTINE ldf_eiv_dia( psi_uw, psi_vw ) + !!---------------------------------------------------------------------- + !! *** ROUTINE ldf_eiv_dia *** + !! + !! ** Purpose : diagnose the eddy induced velocity and its associated + !! vertically integrated heat transport. + !! + !! ** Method : + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: psi_uw, psi_vw ! streamfunction [m3/s] + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zztmp ! local scalar + REAL(wp), DIMENSION(jpi,jpj) :: zw2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,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 ==! + CALL lbc_lnk_multi( 'ldftra', psi_uw, 'U', -1. , psi_vw, 'V', -1. ) + ! +!!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 ! e2u e3u u_eiv = -dk[psi_uw] + zw3d(:,:,jk) = ( psi_uw(:,:,jk+1) - psi_uw(:,:,jk) ) / ( e2u(:,:) * e3u_n(:,:,jk) ) + END DO + CALL iom_put( "uoce_eiv", zw3d ) + ! + DO jk = 1, jpkm1 ! e1v e3v v_eiv = -dk[psi_vw] + zw3d(:,:,jk) = ( psi_vw(:,:,jk+1) - psi_vw(:,:,jk) ) / ( e1v(:,:) * e3v_n(:,:,jk) ) + END DO + CALL iom_put( "voce_eiv", zw3d ) + ! + DO jk = 1, jpkm1 ! e1 e2 w_eiv = dk[psix] + dk[psix] + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 lbc_lnk( 'ldftra', zw3d, 'T', 1. ) ! lateral boundary condition + CALL iom_put( "woce_eiv", zw3d ) + ! + IF( iom_use('weiv_masstr') ) THEN ! vertical mass transport & its square value + zw2d(:,:) = rau0 * e1e2t(:,:) + 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) = rau0 * ( 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 * rau0 * rcp + IF( iom_use('ueiv_heattr') .OR. iom_use('ueiv_heattr3d') ) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) & + & * ( tsn (ji,jj,jk,jp_tem) + tsn (ji+1,jj,jk,jp_tem) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. ) + CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. ) + 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) = rau0 * ( 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) & + & * ( tsn (ji,jj,jk,jp_tem) + tsn (ji,jj+1,jk,jp_tem) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'ldftra', zw2d, 'V', -1. ) + CALL iom_put( "veiv_heattr", zztmp * zw2d ) ! heat transport in j-direction + CALL iom_put( "veiv_heattr", zztmp * zw3d ) ! heat transport in j-direction + ! + IF( ln_diaptr ) CALL dia_ptr_hst( jp_tem, 'eiv', 0.5 * zw3d ) + ! + zztmp = 0.5_wp * 0.5 + IF( iom_use('ueiv_salttr') .OR. iom_use('ueiv_salttr3d')) THEN + zw2d(:,:) = 0._wp + zw3d(:,:,:) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) * ( psi_uw(ji,jj,jk+1) - psi_uw(ji,jj,jk) ) & + & * ( tsn (ji,jj,jk,jp_sal) + tsn (ji+1,jj,jk,jp_sal) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'ldftra', zw2d, 'U', -1. ) + CALL lbc_lnk( 'ldftra', zw3d, 'U', -1. ) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zw3d(ji,jj,jk) = zw3d(ji,jj,jk) + ( psi_vw(ji,jj,jk+1) - psi_vw(ji,jj,jk) ) & + & * ( tsn (ji,jj,jk,jp_sal) + tsn (ji,jj+1,jk,jp_sal) ) + zw2d(ji,jj) = zw2d(ji,jj) + zw3d(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'ldftra', zw2d, 'V', -1. ) + CALL iom_put( "veiv_salttr", zztmp * zw2d ) ! salt transport in j-direction + CALL iom_put( "veiv_salttr", zztmp * zw3d ) ! salt transport in j-direction + ! + IF( ln_diaptr ) CALL dia_ptr_hst( jp_sal, 'eiv', 0.5 * zw3d ) + ! + ! + END SUBROUTINE ldf_eiv_dia + + !!====================================================================== +END MODULE ldftra diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/ddatetoymdhms.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/ddatetoymdhms.h90 new file mode 100644 index 0000000..edd4f88 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/ddatetoymdhms.h90 @@ -0,0 +1,43 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/diaobs.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/diaobs.F90 new file mode 100644 index 0000000..9bc2b34 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/diaobs.F90 @@ -0,0 +1,1013 @@ +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_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_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 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=6), PUBLIC, DIMENSION(:), ALLOCATABLE :: cobstypesprof, cobstypessurf !: Profile & surface obs types + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE dia_obs_init + !!---------------------------------------------------------------------- + !! *** 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, 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 + ! + 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 + ! + 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 :: llvar1 ! Logical for profile variable 1 + LOGICAL :: llvar2 ! Logical for profile variable 1 + 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(wp), DIMENSION(jpi,jpj) :: zglam1, zglam2 ! Model longitudes for profile variable 1 & 2 + REAL(wp), DIMENSION(jpi,jpj) :: zgphi1, zgphi2 ! Model latitudes for profile variable 1 & 2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zmask1, zmask2 ! Model land/sea mask associated with variable 1 & 2 + !! + 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_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_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, & + & 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 + REWIND( numnam_ref ) ! Namelist namobs in reference namelist + READ ( numnam_ref, namobs, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namobs in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namobs in configuration 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,*) ' Type of horizontal interpolation method nn_2dint = ', nn_2dint + 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 + CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'prof ', & + & cn_profbfiles, ifilesprof, cobstypesprof, clproffiles ) + ENDIF + IF( ln_vel3d ) THEN + jtype = jtype + 1 + CALL obs_settypefiles( nproftypes, jpmaxnfiles, jtype, 'vel ', & + & cn_velfbfiles, ifilesprof, cobstypesprof, clproffiles ) + ENDIF + ! + 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 + CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sla ', & + & cn_slafbfiles, ifilessurf, cobstypessurf, clsurffiles ) + CALL obs_setinterpopts( nsurftypes, jtype, 'sla ', & + & nn_2dint, nn_2dint_sla, & + & rn_sla_avglamscl, rn_sla_avgphiscl, & + & ln_sla_fp_indegs, .FALSE., & + & n2dintsurf, zavglamscl, zavgphiscl, & + & lfpindegs, llnightav ) + ENDIF + IF( ln_sst ) THEN + jtype = jtype + 1 + CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sst ', & + & cn_sstfbfiles, ifilessurf, cobstypessurf, clsurffiles ) + CALL obs_setinterpopts( nsurftypes, jtype, 'sst ', & + & nn_2dint, nn_2dint_sst, & + & rn_sst_avglamscl, rn_sst_avgphiscl, & + & ln_sst_fp_indegs, ln_sstnight, & + & n2dintsurf, zavglamscl, zavgphiscl, & + & lfpindegs, llnightav ) + ENDIF +#if defined key_si3 || defined key_cice + IF( ln_sic ) THEN + jtype = jtype + 1 + CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sic ', & + & cn_sicfbfiles, ifilessurf, cobstypessurf, clsurffiles ) + CALL obs_setinterpopts( nsurftypes, jtype, 'sic ', & + & nn_2dint, nn_2dint_sic, & + & rn_sic_avglamscl, rn_sic_avgphiscl, & + & ln_sic_fp_indegs, .FALSE., & + & n2dintsurf, zavglamscl, zavgphiscl, & + & lfpindegs, llnightav ) + ENDIF +#endif + IF( ln_sss ) THEN + jtype = jtype + 1 + CALL obs_settypefiles( nsurftypes, jpmaxnfiles, jtype, 'sss ', & + & cn_sssfbfiles, ifilessurf, cobstypessurf, clsurffiles ) + CALL obs_setinterpopts( nsurftypes, jtype, 'sss ', & + & nn_2dint, nn_2dint_sss, & + & rn_sss_avglamscl, rn_sss_avgphiscl, & + & ln_sss_fp_indegs, .FALSE., & + & n2dintsurf, zavglamscl, zavgphiscl, & + & lfpindegs, llnightav ) + ENDIF + ! + 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 < 0 .OR. nn_2dint > 6 ) THEN + CALL ctl_stop('dia_obs_init: Choice of 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 + ! + nvarsprof(jtype) = 2 + IF ( TRIM(cobstypesprof(jtype)) == 'prof' ) THEN + nextrprof(jtype) = 1 + llvar1 = ln_t3d + llvar2 = ln_s3d + zglam1 = glamt + zgphi1 = gphit + zmask1 = tmask + zglam2 = glamt + zgphi2 = gphit + zmask2 = tmask + ENDIF + IF ( TRIM(cobstypesprof(jtype)) == 'vel' ) THEN + nextrprof(jtype) = 2 + llvar1 = ln_vel3d + llvar2 = ln_vel3d + zglam1 = glamu + zgphi1 = gphiu + zmask1 = umask + zglam2 = glamv + zgphi2 = gphiv + zmask2 = vmask + 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, llvar1, llvar2, & + & ln_ignmis, ln_s_at_t, .FALSE., & + & 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), & + & llvar1, llvar2, & + & jpi, jpj, jpk, & + & zmask1, zglam1, zgphi1, zmask2, zglam2, zgphi2, & + & ln_nea, ln_bound_reject, & + & kdailyavtypes = nn_profdavtypes ) + 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 + ! + ! 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) ) + ! + 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) ) + 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 + END DO + ! + DEALLOCATE( ifilessurf, clsurffiles ) + ! + ENDIF + ! + END SUBROUTINE dia_obs_init + + + SUBROUTINE dia_obs( kstp ) + !!---------------------------------------------------------------------- + !! *** 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 dom_oce, ONLY : gdept_n, gdept_1d ! Ocean space and time domain variables + USE phycst , ONLY : rday ! Physical constants + USE oce , ONLY : tsn, un, vn, sshn ! Ocean dynamics and tracers variables + USE phycst , ONLY : rday ! Physical constants +#if defined key_si3 + USE ice , ONLY : at_i ! SI3 Ice model variables +#endif +#if defined key_cice + USE sbc_oce, ONLY : fr_i ! ice fraction +#endif + + IMPLICIT NONE + + !! * Arguments + INTEGER, INTENT(IN) :: kstp ! Current timestep + !! * Local declarations + INTEGER :: idaystp ! Number of timesteps per day + INTEGER :: jtype ! Data loop variable + INTEGER :: jvar ! Variable number + INTEGER :: ji, jj ! Loop counters + REAL(wp), DIMENSION(jpi,jpj,jpk) :: & + & zprofvar1, & ! Model values for 1st variable in a prof ob + & zprofvar2 ! Model values for 2nd variable in a prof ob + REAL(wp), DIMENSION(jpi,jpj,jpk) :: & + & zprofmask1, & ! Mask associated with zprofvar1 + & zprofmask2 ! Mask associated with zprofvar2 + REAL(wp), DIMENSION(jpi,jpj) :: & + & zsurfvar, & ! Model values equivalent to surface ob. + & zsurfmask ! Mask associated with surface variable + REAL(wp), DIMENSION(jpi,jpj) :: & + & zglam1, & ! Model longitudes for prof variable 1 + & zglam2, & ! Model longitudes for prof variable 2 + & zgphi1, & ! Model latitudes for prof variable 1 + & zgphi2 ! Model latitudes for prof variable 2 + + !----------------------------------------------------------------------- + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'dia_obs : Call the observation operators', kstp + WRITE(numout,*) '~~~~~~~' + ENDIF + + idaystp = NINT( rday / rdt ) + + !----------------------------------------------------------------------- + ! Call the profile and surface observation operators + !----------------------------------------------------------------------- + + IF ( nproftypes > 0 ) THEN + + DO jtype = 1, nproftypes + + SELECT CASE ( TRIM(cobstypesprof(jtype)) ) + CASE('prof') + zprofvar1(:,:,:) = tsn(:,:,:,jp_tem) + zprofvar2(:,:,:) = tsn(:,:,:,jp_sal) + zprofmask1(:,:,:) = tmask(:,:,:) + zprofmask2(:,:,:) = tmask(:,:,:) + zglam1(:,:) = glamt(:,:) + zglam2(:,:) = glamt(:,:) + zgphi1(:,:) = gphit(:,:) + zgphi2(:,:) = gphit(:,:) + CASE('vel') + zprofvar1(:,:,:) = un(:,:,:) + zprofvar2(:,:,:) = vn(:,:,:) + zprofmask1(:,:,:) = umask(:,:,:) + zprofmask2(:,:,:) = vmask(:,:,:) + zglam1(:,:) = glamu(:,:) + zglam2(:,:) = glamv(:,:) + zgphi1(:,:) = gphiu(:,:) + zgphi2(:,:) = gphiv(:,:) + CASE DEFAULT + CALL ctl_stop( 'Unknown profile observation type '//TRIM(cobstypesprof(jtype))//' in dia_obs' ) + END SELECT + + CALL obs_prof_opt( profdataqc(jtype), kstp, jpi, jpj, jpk, & + & nit000, idaystp, & + & zprofvar1, zprofvar2, & + & gdept_n(:,:,:), gdepw_n(:,:,:), & + & zprofmask1, zprofmask2, & + & zglam1, zglam2, zgphi1, zgphi2, & + & nn_1dint, nn_2dint, & + & kdailyavtypes = nn_profdavtypes ) + + END DO + + 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(:,:) = tsn(:,:,1,jp_tem) + CASE('sla') + zsurfvar(:,:) = sshn(:,:) + CASE('sss') + zsurfvar(:,:) = tsn(:,:,1,jp_sal) + 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 +#if defined key_cice || defined key_si3 + zsurfvar(:,:) = fr_i(:,:) +#else + CALL ctl_stop( ' Trying to run sea-ice observation operator', & + & ' but no sea-ice model appears to have been defined' ) +#endif + 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, 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 + & rdt + + IMPLICIT NONE + + !! * Arguments + REAL(KIND=dp), INTENT(OUT) :: ddobs ! Date in YYYYMMDD.HHMMSS + INTEGER :: 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 * rdt / 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 * rdt / 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=dp), 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(dp), INTENT(OUT) :: ddobsfin ! Final date in YYYYMMDD.HHMMSS + + CALL calc_date( nitend, ddobsfin ) + + END SUBROUTINE fin_date + + SUBROUTINE obs_settypefiles( ntypes, jpmaxnfiles, jtype, ctypein, & + & cfilestype, 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, INTENT(IN) :: jtype ! Index of the current type of obs + INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & + & ifiles ! Out appended number of files for this type + + CHARACTER(len=6), INTENT(IN) :: ctypein + CHARACTER(len=128), DIMENSION(jpmaxnfiles), INTENT(IN) :: & + & cfilestype ! In list of files for this obs type + CHARACTER(len=6), DIMENSION(ntypes), INTENT(INOUT) :: & + & cobstypes ! Out appended list of obs types + CHARACTER(len=128), DIMENSION(ntypes, jpmaxnfiles), INTENT(INOUT) :: & + & cfiles ! Out appended list of files for all types + + !Local variables + INTEGER :: jfile + + cfiles(jtype,:) = cfilestype(:) + cobstypes(jtype) = ctypein + 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(ctypein)// & + & ' 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 SUBROUTINE obs_settypefiles + + SUBROUTINE obs_setinterpopts( ntypes, jtype, ctypein, & + & n2dint_default, n2dint_type, & + & zavglamscl_type, zavgphiscl_type, & + & lfp_indegs_type, lavnight_type, & + & n2dint, zavglamscl, zavgphiscl, & + & 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) :: & + & zavglamscl_type, & !E/W diameter of obs footprint for this type + & zavgphiscl_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=6), INTENT(IN) :: ctypein + + INTEGER, DIMENSION(ntypes), INTENT(INOUT) :: & + & n2dint + REAL(wp), DIMENSION(ntypes), INTENT(INOUT) :: & + & zavglamscl, zavgphiscl + LOGICAL, DIMENSION(ntypes), INTENT(INOUT) :: & + & lfpindegs, lavnight + + lavnight(jtype) = lavnight_type + + IF ( (n2dint_type >= 1) .AND. (n2dint_type <= 6) ) THEN + n2dint(jtype) = n2dint_type + ELSE + n2dint(jtype) = n2dint_default + ENDIF + + ! For averaging observation footprints set options for size of footprint + IF ( (n2dint(jtype) > 4) .AND. (n2dint(jtype) <= 6) ) THEN + IF ( zavglamscl_type > 0._wp ) THEN + zavglamscl(jtype) = zavglamscl_type + ELSE + CALL ctl_stop( 'Incorrect value set for averaging footprint '// & + 'scale (zavglamscl) for observation type '//TRIM(ctypein) ) + ENDIF + + IF ( zavgphiscl_type > 0._wp ) THEN + zavgphiscl(jtype) = zavgphiscl_type + ELSE + CALL ctl_stop( 'Incorrect value set for averaging footprint '// & + 'scale (zavgphiscl) 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: ',zavglamscl(jtype) + WRITE(numout,*) ' '//' with N/S scale: ',zavgphiscl(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/NEMO_4.0.4_surge/src/OCE/OBS/find_obs_proc.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/find_obs_proc.h90 new file mode 100644 index 0000000..769937b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/find_obs_proc.h90 @@ -0,0 +1,60 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 nlci and nlcj) + ! 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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/greg2jul.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/greg2jul.h90 new file mode 100644 index 0000000..5bef12f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/grt_cir_dis.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/grt_cir_dis.h90 new file mode 100644 index 0000000..6488f52 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/grt_cir_dis.h90 @@ -0,0 +1,33 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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) + + grt_cir_dis = & + & ASIN( SQRT( 1.0 - ( pa1 * pa2 + pb1 * pb2 + pc1 * pc2 )**2 ) ) + + END FUNCTION grt_cir_dis diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/grt_cir_dis_saa.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/grt_cir_dis_saa.h90 new file mode 100644 index 0000000..f70650a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/grt_cir_dis_saa.h90 @@ -0,0 +1,32 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/jul2greg.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/jul2greg.h90 new file mode 100644 index 0000000..f9b2823 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/julian.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/julian.F90 new file mode 100644 index 0000000..3d5b4f6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/julian.F90 @@ -0,0 +1,33 @@ +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$ +CONTAINS + +#include "jul2greg.h90" + +#include "greg2jul.h90" + +END MODULE julian diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/linquad.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/linquad.h90 new file mode 100644 index 0000000..fbb8e3b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/linquad.h90 @@ -0,0 +1,59 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/maxdist.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/maxdist.h90 new file mode 100644 index 0000000..c2a4e8a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/maxdist.h90 @@ -0,0 +1,76 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + + REAL 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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/mpp_map.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/mpp_map.F90 new file mode 100644 index 0000000..2e62fc6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/mpp_map.F90 @@ -0,0 +1,85 @@ +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 ! Ocean parameters + USE dom_oce , ONLY : mig, mjg, nldi, nlei, nldj, nlej, nlci, nlcj, narea ! Ocean space and time domain variables +#if defined key_mpp_mpi + USE lib_mpp, ONLY : mpi_comm_oce ! MPP library +#endif + 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$ + !! 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 ! +#if defined key_mpp_mpi + INTEGER :: ierr + +INCLUDE 'mpif.h' +#endif + !!---------------------------------------------------------------------- + + 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(nlci),mjg(1):mjg(nlcj)) = narea + + ! Get global data + +#if defined key_mpp_mpi + + ! 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 ) +#else + + ! No MPP: Just copy the data + mppmap(:,:) = imppmap(:,:) +#endif + ! + END SUBROUTINE mppmap_init + + !!====================================================================== +END MODULE mpp_map diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_averg_h2d.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_averg_h2d.F90 new file mode 100644 index 0000000..209c75c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_averg_h2d.F90 @@ -0,0 +1,827 @@ +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, & + & nproc + 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$ + !! 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, pobsmask, 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 + 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 + + + !------------------------------------------------------------------------ + ! + !------------------------------------------------------------------------ + + !------------------------------------------------------------------------ + ! 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 = MAXVAL( e1t(:,:)*pmask(:,:) ) + ze2min = MAXVAL( e2t(:,:)*pmask(:,:) ) + + ze1min = ze1min - MAXVAL( (ze1min-e1t(:,:))*pmask(:,:) ) + ze2min = ze2min - MAXVAL( (ze2min-e2t(:,:))*pmask(:,:) ) + + 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_const.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_const.F90 new file mode 100644 index 0000000..7a2a028 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_const.F90 @@ -0,0 +1,23 @@ +MODULE obs_const + !!===================================================================== + !! *** MODULE obs_const *** + !! Observation diagnostics: Constants used by many modules + !!===================================================================== + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_conv.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_conv.F90 new file mode 100644 index 0000000..56db572 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_conv.F90 @@ -0,0 +1,46 @@ +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, ONLY : & ! Precision variables + & wp + 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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obs_conv_functions.h90" + +END MODULE obs_conv diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_conv_functions.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_conv_functions.h90 new file mode 100644 index 0000000..2e733a0 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_conv_functions.h90 @@ -0,0 +1,294 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_fbm.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_fbm.F90 new file mode 100644 index 0000000..850f965 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_fbm.F90 @@ -0,0 +1,1998 @@ +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$ + !! 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', & + & __LINE__ ) + 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', __LINE__ ) + 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', __LINE__ ) + 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', & + & __LINE__ ) + 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', __LINE__ ) + 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', __LINE__ ) + ENDIF + IF ( fbdata1%nobs > fbdata2%nobs ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output kobs smaller than input kobs', __LINE__ ) + ENDIF + IF ( fbdata1%nlev > fbdata2%nlev ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output klev smaller than input klev', __LINE__ ) + ENDIF + IF ( fbdata1%nadd > fbdata2%nadd ) THEN + CALL warning ( 'copy_obfbdata: ' // & + & 'output nadd smaller than input nadd', __LINE__ ) + ENDIF + IF ( fbdata1%next > fbdata2%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output next smaller than input next', __LINE__ ) + ENDIF + IF ( fbdata1%lgrid .NEQV. fbdata2%lgrid ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'lgrid inconsistent', __LINE__ ) + ENDIF + IF ( fbdata1%next > fbdata2%next ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output next smaller than input next', __LINE__ ) + ENDIF + IF ( fbdata1%nqcf > fbdata2%nqcf ) THEN + CALL fatal_error( 'copy_obfbdata: ' // & + & 'output smaller than input kext', __LINE__ ) + 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', & + & __LINE__ ) + ENDIF + + ! Check allocation status of fbdata2 and abort if already allocated + + IF ( fbdata2%lalloc ) THEN + CALL fatal_error( 'subsample_obfbdata: ' // & + & 'fbdata2 already allocated', __LINE__ ) + 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', & + & __LINE__ ) + ENDIF + END DO + + ! Check allocation status of fbdataout + + IF ( .NOT.fbdataout%lalloc ) THEN + CALL fatal_error( 'merge_obfbdata: output data not allocated', & + & __LINE__ ) + 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, __LINE__ ) + CALL chkerr( nf90_set_fill( idfile, nf90_nofill, ioldfill ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & + & 'NEMO observation operator output' ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'Convention', & + & 'NEMO unified observation operator output' ),& + & cpname,__LINE__ ) + + ! Create the dimensions + + CALL chkerr( nf90_def_dim( idfile, 'N_OBS' , fbdata%nobs, idodim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'N_LEVELS', fbdata%nlev, idldim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'N_VARS', fbdata%nvar, idvdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'N_QCF', fbdata%nqcf, idqcdim ),& + & cpname,__LINE__ ) + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_def_dim( idfile, 'N_ENTRIES', fbdata%nadd, idadim ), & + & cpname,__LINE__ ) + ENDIF + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_def_dim( idfile, 'N_EXTRA', fbdata%next, idedim ), & + & cpname,__LINE__ ) + ENDIF + CALL chkerr( nf90_def_dim( idfile, 'STRINGNAM', ilenname, idsndim ), & + & cpname,__LINE__ ) + IF (fbdata%lgrid) THEN + CALL chkerr( nf90_def_dim( idfile, 'STRINGGRID', ilengrid, idsgdim ),& + & cpname,__LINE__ ) + ENDIF + CALL chkerr( nf90_def_dim( idfile, 'STRINGWMO', ilenwmo, idswdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'STRINGTYP', ilentyp, idstdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim( idfile, 'STRINGJULD', ilenjuld, idjddim ), & + & cpname,__LINE__ ) + + ! Define netCDF variables for header information + + incdim2(1) = idsndim + incdim2(2) = idvdim + + CALL chkerr( nf90_def_var( idfile, 'VARIABLES', nf90_char, incdim2, & + & idvard ), cpname, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idcdtyp, & + & 'Code instrument type' ) + incdim1(1) = idodim + CALL chkerr( nf90_def_var( idfile, 'LONGITUDE', & + & nf90_double, incdim1, & + & idplam ), cpname, __LINE__ ) + CALL putvaratt_obfbdata( idfile, idplam, & + & 'Longitude', cdunits = 'degrees_east', & + & rfillvalue = fbrmdi ) + CALL chkerr( nf90_def_var( idfile, 'LATITUDE', & + & nf90_double, incdim1, & + & idpphi ), cpname, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + CALL putvaratt_obfbdata( idfile, ididqcf, & + & 'Quality flags on depth', & + & conventions = cdqcfconv ) + CALL chkerr( nf90_def_var( idfile, 'JULD', & + & nf90_double, incdim1, & + & idptim ), cpname, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + + ! Write the variables + + CALL chkerr( nf90_put_var( idfile, idvard, fbdata%cname ), & + & cpname, __LINE__ ) + + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_put_var( idfile, idaddd, fbdata%caddname ), & + & cpname, __LINE__ ) + ENDIF + + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_put_var( idfile, idextd, fbdata%cextname ), & + & cpname, __LINE__ ) + ENDIF + + CALL chkerr( nf90_put_var( idfile, idptimr, fbdata%cdjuldref ), & + & cpname, __LINE__ ) + + ! Only write the data if observation is available + + IF ( fbdata%nobs > 0 ) THEN + + CALL chkerr( nf90_put_var( idfile, idcdwmo, fbdata%cdwmo ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idcdtyp, fbdata%cdtyp ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idplam, fbdata%plam ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idpphi, fbdata%pphi ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idpdep, fbdata%pdep ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idptim, fbdata%ptim ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idioqc, fbdata%ioqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idioqcf, fbdata%ioqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idipqc, fbdata%ipqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idipqcf, fbdata%ipqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, iditqc, fbdata%itqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, iditqcf, fbdata%itqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, ididqc, fbdata%idqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, ididqcf, fbdata%idqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idkindex, fbdata%kindex ), & + & cpname, __LINE__ ) + + DO jv = 1, fbdata%nvar + CALL chkerr( nf90_put_var( idfile, idpob(jv), fbdata%pob(:,:,jv) ), & + & cpname, __LINE__ ) + IF ( fbdata%nadd > 0 ) THEN + DO je = 1, fbdata%nadd + CALL chkerr( nf90_put_var( idfile, idpadd(je,jv), & + & fbdata%padd(:,:,je,jv) ), & + & cpname, __LINE__ ) + END DO + ENDIF + CALL chkerr( nf90_put_var( idfile, idivqc(jv), & + & fbdata%ivqc(:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idivqcf(jv), & + & fbdata%ivqcf(:,:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idivlqc(jv), & + & fbdata%ivlqc(:,:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idivlqcf(jv), & + & fbdata%ivlqcf(:,:,:,jv) ),& + & cpname, __LINE__ ) + IF (fbdata%lgrid) THEN + CALL chkerr( nf90_put_var( idfile, idiobsi(jv), & + & fbdata%iobsi(:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idiobsj(jv), & + & fbdata%iobsj(:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idiobsk(jv), & + & fbdata%iobsk(:,:,jv) ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idcgrid(jv), & + & fbdata%cgrid(jv) ), & + & cpname, __LINE__ ) + 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, __LINE__ ) + END DO + ENDIF + + ENDIF + + ! Close the file + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + + 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 :: 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, __LINE__ ) + + IF ( PRESENT(cdunits) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, 'units', & + & TRIM(cdunits) ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(conventions) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, 'Conventions', & + & TRIM(conventions) ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(cfillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & TRIM(cfillvalue) ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(ifillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & ifillvalue ), & + & cpname, __LINE__ ) + + ENDIF + + IF ( PRESENT(rfillvalue) ) THEN + + CALL chkerr( nf90_put_att( idfile, idvar, '_Fillvalue', & + & rfillvalue ), & + & cpname, __LINE__ ) + + 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 :: 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, __LINE__ ) + + ! Get input dimensions + + CALL chkerr( nf90_inq_dimid( idfile, 'N_OBS' , idodim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idodim, len=nobs ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inq_dimid( idfile, 'N_LEVELS', idldim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idldim, len=nlev ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inq_dimid( idfile, 'N_VARS', idvdim ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idvdim, len=nvar ), & + & cpname,__LINE__ ) + IF ( nf90_inq_dimid( idfile, 'N_ENTRIES', idadim ) == 0 ) THEN + CALL chkerr( nf90_inquire_dimension( idfile, idadim, len=nadd ), & + & cpname,__LINE__ ) + ELSE + nadd = 0 + ENDIF + IF ( nf90_inq_dimid( idfile, 'N_EXTRA', idedim ) == 0 ) THEN + CALL chkerr( nf90_inquire_dimension( idfile, idedim, len=next ), & + & cpname,__LINE__ ) + 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, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idvard, fbdata%cname ), & + & cpname, __LINE__ ) + IF ( fbdata%nadd > 0 ) THEN + CALL chkerr( nf90_inq_varid( idfile, 'ENTRIES', idaddd ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idaddd, fbdata%caddname ), & + & cpname, __LINE__ ) + ENDIF + IF ( fbdata%next > 0 ) THEN + CALL chkerr( nf90_inq_varid( idfile, 'EXTRA', idextd ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idextd, fbdata%cextname ), & + & cpname, __LINE__ ) + ENDIF + + CALL chkerr( nf90_inq_varid( idfile, 'JULD_REFERENCE', idptimr ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idptimr, fbdata%cdjuldref ), & + & cpname, __LINE__ ) + + IF ( fbdata%nobs > 0 ) THEN + + CALL chkerr( nf90_inq_varid( idfile, 'STATION_IDENTIFIER', idcdwmo ),& + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idcdwmo, fbdata%cdwmo ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'STATION_TYPE', idcdtyp ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idcdtyp, fbdata%cdtyp), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'LONGITUDE', idplam ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idplam, fbdata%plam ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'LATITUDE', idpphi ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpphi, fbdata%pphi ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH', idpdep ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpdep, fbdata%pdep ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD', idptim ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idptim, fbdata%ptim ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC', idioqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idioqc, fbdata%ioqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'OBSERVATION_QC_FLAGS', idioqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idioqcf, fbdata%ioqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC', idipqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idipqc, fbdata%ipqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'POSITION_QC_FLAGS', idipqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idipqcf, fbdata%ipqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC', ididqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, ididqc, fbdata%idqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'DEPTH_QC_FLAGS', ididqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, ididqcf, fbdata%idqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC', iditqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, iditqc, fbdata%itqc ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'JULD_QC_FLAGS', iditqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, iditqcf, fbdata%itqcf ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'ORIGINAL_FILE_INDEX', idkindex ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idkindex, fbdata%kindex ), & + & cpname, __LINE__ ) + + ! 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, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpob(jv), & + & fbdata%pob(:,:,jv) ), & + & cpname, __LINE__ ) + 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, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpadd(je,jv), & + & fbdata%padd(:,:,je,jv) ), & + & cpname, __LINE__ ) + 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, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivqc(jv), & + & fbdata%ivqc(:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_QC_FLAGS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivqcf(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivqcf(jv), & + & fbdata%ivqcf(:,:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqc(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivlqc(jv), & + & fbdata%ivlqc(:,:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_LEVEL_QC_FLAGS' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idivlqcf(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idivlqcf(jv), & + & fbdata%ivlqcf(:,:,:,jv) ), & + & cpname, __LINE__ ) + IF ( lgrid ) THEN + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSI' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsi(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idiobsi(jv), & + & fbdata%iobsi(:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSJ' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsj(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idiobsj(jv), & + & fbdata%iobsj(:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_IOBSK' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idiobsk(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idiobsk(jv), & + & fbdata%iobsk(:,:,jv) ), & + & cpname, __LINE__ ) + WRITE(cdtmp,'(2A)') TRIM(fbdata%cname(jv)),'_GRID' + CALL chkerr( nf90_inq_varid( idfile, cdtmp, idcgrid(jv) ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idcgrid(jv), & + & fbdata%cgrid(jv) ), & + & cpname, __LINE__ ) + 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, __LINE__ ) + CALL chkerr( nf90_get_var( idfile, idpext(je), & + & fbdata%pext(:,:,je) ), & + & cpname, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + 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, __LINE__ ) + + 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, __LINE__ ) + + CALL chkerr( nf90_get_att( idfile, idvar, 'units', & + & cdunits ), & + & cpname, __LINE__ ) + + END SUBROUTINE getvaratt_obfbdata + +END MODULE obs_fbm diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_grd_bruteforce.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_grd_bruteforce.h90 new file mode 100644 index 0000000..5a41fa3 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_grid.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_grid.F90 new file mode 100644 index 0000000..09fe5f2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_grid.F90 @@ -0,0 +1,1182 @@ +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, 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$ + !! 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, nlci, 1, nlcj, & + & nproc, jpnij, & + & glamt, gphit, tmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'U' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, nlci, 1, nlcj, & + & nproc, jpnij, & + & glamu, gphiu, umask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'V' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, nlci, 1, nlcj, & + & nproc, jpnij, & + & glamv, gphiv, vmask, & + & kobsin, plam, pphi, & + & kobsi, kobsj, kproc ) + ELSEIF ( cdgrid == 'F' ) THEN + CALL obs_grd_bruteforce( jpi, jpj, jpiglo, jpjglo, & + & 1, nlci, 1, nlcj, & + & nproc, 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 + +#include "obs_grd_bruteforce.h90" + + 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=nproc 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 = nproc + 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, nlcj + DO ji = 1, nlci + 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) = nproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = nproc + 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) = nproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = nproc + 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) = nproc + 1000000 + kobsi(jo) = ji + 1 + kobsj(jo) = jj + 1 + CYCLE + ELSE + kproc(jo) = nproc + 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, DIMENSION(histsize) :: & + & fhistx1, fhistx2, fhisty1, fhisty2 + REAL(wp) :: histtol + + 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 + WRITE(cfname, FMT="(A,'_',I4.4,'of',I4.4,'by',I4.4,'.nc')") & + & TRIM(cn_gridsearchfile), nproc, jpni, jpnj + 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, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxxdiff', maxxdiff ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'maxydiff', maxydiff ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlon', dlon ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'dlat', dlat ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'lonmin', lonmin ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_att( idfile, nf90_global, 'latmin', latmin ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_inq_dimid(idfile, 'nx' , idnx), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idnx, len = nlons ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_dimid(idfile, 'ny' , idny), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inquire_dimension( idfile, idny, len = nlats ), & + & cpname, __LINE__ ) + + 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, __LINE__ ) + CALL chkerr( nf90_get_var ( idfile, idxpos, ixpos), & + & cpname, __LINE__ ) + CALL chkerr( nf90_inq_varid( idfile, 'YPOS', idypos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_get_var ( idfile, idypos, iypos), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + ! 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, nlci, 1, nlcj, & + & nproc, 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. ( nproc==0 ) ) ) THEN + + CALL chkerr( nf90_create (TRIM(cfname), nf90_clobber, idfile), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'title', & + & 'Mapping file from lon/lat to model grid point' ),& + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxxdiff', & + & maxxdiff ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'maxydiff', & + & maxydiff ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlon', dlon ),& + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'dlat', dlat ),& + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'lonmin', & + & lonmin ), & + & cpname,__LINE__ ) + CALL chkerr( nf90_put_att( idfile, nf90_global, 'latmin', & + & latmin ), & + & cpname,__LINE__ ) + + CALL chkerr( nf90_def_dim(idfile, 'nx' , nlons, idnx), & + & cpname,__LINE__ ) + CALL chkerr( nf90_def_dim(idfile, 'ny' , nlats, idny), & + & cpname,__LINE__ ) + + incdim(1) = idnx + incdim(2) = idny + + CALL chkerr( nf90_def_var( idfile, 'LON', nf90_float, incdim, & + & idlon ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idlon, 'long_name', & + & 'longitude' ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_def_var( idfile, 'LAT', nf90_float, incdim, & + & idlat ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idlat, 'long_name', & + & 'latitude' ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_def_var( idfile, 'XPOS', nf90_int, incdim, & + & idxpos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idxpos, 'long_name', & + & 'x position' ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idxpos, '_FillValue', -1 ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_def_var( idfile, 'YPOS', nf90_int, incdim, & + & idypos ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idypos, 'long_name', & + & 'y position' ), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_att( idfile, idypos, '_FillValue', -1 ), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_enddef( idfile ), cpname, __LINE__ ) + + CALL chkerr( nf90_put_var( idfile, idlon, lons), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idlat, lats), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idxpos, ixpos), & + & cpname, __LINE__ ) + CALL chkerr( nf90_put_var( idfile, idypos, iypos), & + & cpname, __LINE__ ) + + CALL chkerr( nf90_close( idfile ), cpname, __LINE__ ) + + ! 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 + +#include "obs_level_search.h90" + +#include "linquad.h90" + +#include "maxdist.h90" + +#include "find_obs_proc.h90" + +END MODULE obs_grid + diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_h2d.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_h2d.F90 new file mode 100644 index 0000000..be5da07 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_h2d.F90 @@ -0,0 +1,58 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsinter_h2d.h90" + +END MODULE obs_inter_h2d diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_sup.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_sup.F90 new file mode 100644 index 0000000..0db2740 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_sup.F90 @@ -0,0 +1,386 @@ +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$ + !! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_z1d.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_z1d.F90 new file mode 100644 index 0000000..96e3dbe --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_inter_z1d.F90 @@ -0,0 +1,37 @@ +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, ONLY : & ! Precision variables + & wp + + 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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "obsinter_z1d.h90" + +END MODULE obs_inter_z1d + diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_level_search.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_level_search.h90 new file mode 100644 index 0000000..af8ec34 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_level_search.h90 @@ -0,0 +1,51 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_mpp.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_mpp.F90 new file mode 100644 index 0000000..0ae8509 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_mpp.F90 @@ -0,0 +1,445 @@ +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 + !!---------------------------------------------------------------------- +# define mpivar mpi_double_precision + !!---------------------------------------------------------------------- + !! 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 dom_oce, ONLY : nproc, mig, mjg ! Ocean space and time domain variables + USE mpp_map, ONLY : mppmap + USE in_out_manager +#if defined key_mpp_mpi + USE lib_mpp, ONLY : mpi_comm_oce ! MPP library +#endif + 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$ + !! 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 + ! +#if defined key_mpp_mpi + ! + INTEGER :: ierr + ! +INCLUDE 'mpif.h' + !!---------------------------------------------------------------------- + + ! Call the MPI library to broadcast data + CALL mpi_bcast( kvals, kno, mpi_integer, & + & kroot, mpi_comm_oce, ierr ) +#else + ! no MPI: empty routine +#endif + ! + 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 + ! +#if defined key_mpp_mpi + ! + 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(:) +#else + ! no MPI: empty routine +#endif + 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 + ! +#if defined key_mpp_mpi + ! + ! + 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 + +#else + ! no MPI: empty routine +#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 + ! +#if defined key_mpp_mpi + ! + 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 ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalsout(:) = kvalsin(:) +#endif + ! + 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 + ! +#if defined key_mpp_mpi + ! + 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 ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalout = kvalin +#endif + ! + 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 + ! +#if defined key_mpp_mpi + ! +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, mpivar, & + & mpi_max, mpi_comm_oce, ierr ) + + DEALLOCATE( & + & zcp & + & ) + +#else + ! no MPI: empty routine +#endif + ! + 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 + ! +#if defined key_mpp_mpi + ! +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 ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalsout = kvalsin +#endif + ! + 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) :: kinv, koutv + INTEGER, DIMENSION(knoin) , INTENT(in ) :: kvalsin + INTEGER, DIMENSION(knoout), INTENT( out) :: kvalsout + !! + INTEGER :: ierr + INTEGER :: jproc + ! +#if defined key_mpp_mpi + ! +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 ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + kvalsout = kvalsin +#endif + ! + 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 + ! +#if defined key_mpp_mpi + ! +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, mpivar, & + & pvalsout, koutv, irdsp, mpivar, & + & mpi_comm_oce, ierr ) +#else + !----------------------------------------------------------------------- + ! For no-MPP just return input values + !----------------------------------------------------------------------- + pvalsout = pvalsin +#endif + ! + END SUBROUTINE mpp_alltoallv_real + + !!====================================================================== +END MODULE obs_mpp diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_oper.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_oper.F90 new file mode 100644 index 0000000..3514169 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_oper.F90 @@ -0,0 +1,977 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_prof_opt( prodatqc, kt, kpi, kpj, kpk, & + & kit000, kdaystp, & + & pvar1, pvar2, pgdept, pgdepw, & + & pmask1, pmask2, & + & plam1, plam2, pphi1, pphi2, & + & 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 + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pvar1 , pvar2 ! Model field 1 and 2 + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj,kpk) :: pmask1, pmask2 ! Land-sea mask 1 and 2 + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: plam1 , plam2 ! Model longitude 1 and 2 + REAL(KIND=wp) , INTENT(in ), DIMENSION(kpi,kpj) :: pphi1 , pphi2 ! Model latitudes 1 and 2 + 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 :: & + & igrdi1, & + & igrdi2, & + & igrdj1, & + & igrdj2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: iv_indic + + REAL(KIND=wp) :: zlam + REAL(KIND=wp) :: zphi + REAL(KIND=wp) :: zdaystp + REAL(KIND=wp), DIMENSION(kpk) :: & + & zobsmask1, & + & zobsmask2, & + & zobsk, & + & zobs2k + REAL(KIND=wp), DIMENSION(2,2,1) :: & + & zweig1, & + & zweig2, & + & zweig + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: & + & zmask1, & + & zmask2, & + & zint1, & + & zint2, & + & zinm1, & + & zinm2, & + & zgdept, & + & zgdepw + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: & + & zglam1, & + & zglam2, & + & zgphi1, & + & zgphi2 + REAL(KIND=wp), DIMENSION(1) :: zmsk_1, zmsk_2 + 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 = 1, jpj + DO ji = 1, jpi + prodatqc%vdmean(ji,jj,jk,1) = 0.0 + prodatqc%vdmean(ji,jj,jk,2) = 0.0 + END DO + END DO + END DO + ENDIF + + DO jk = 1, jpk + DO jj = 1, jpj + DO ji = 1, jpi + ! Increment field 1 for computing daily mean + prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & + & + pvar1(ji,jj,jk) + ! Increment field 2 for computing daily mean + prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & + & + pvar2(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 = 1, jpj + DO ji = 1, jpi + prodatqc%vdmean(ji,jj,jk,1) = prodatqc%vdmean(ji,jj,jk,1) & + & * zdaystp + prodatqc%vdmean(ji,jj,jk,2) = prodatqc%vdmean(ji,jj,jk,2) & + & * zdaystp + END DO + END DO + END DO + ENDIF + + ENDIF + + ! Get the data for interpolation + ALLOCATE( & + & igrdi1(2,2,ipro), & + & igrdi2(2,2,ipro), & + & igrdj1(2,2,ipro), & + & igrdj2(2,2,ipro), & + & zglam1(2,2,ipro), & + & zglam2(2,2,ipro), & + & zgphi1(2,2,ipro), & + & zgphi2(2,2,ipro), & + & zmask1(2,2,kpk,ipro), & + & zmask2(2,2,kpk,ipro), & + & zint1(2,2,kpk,ipro), & + & zint2(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 + igrdi1(1,1,iobs) = prodatqc%mi(jobs,1)-1 + igrdj1(1,1,iobs) = prodatqc%mj(jobs,1)-1 + igrdi1(1,2,iobs) = prodatqc%mi(jobs,1)-1 + igrdj1(1,2,iobs) = prodatqc%mj(jobs,1) + igrdi1(2,1,iobs) = prodatqc%mi(jobs,1) + igrdj1(2,1,iobs) = prodatqc%mj(jobs,1)-1 + igrdi1(2,2,iobs) = prodatqc%mi(jobs,1) + igrdj1(2,2,iobs) = prodatqc%mj(jobs,1) + igrdi2(1,1,iobs) = prodatqc%mi(jobs,2)-1 + igrdj2(1,1,iobs) = prodatqc%mj(jobs,2)-1 + igrdi2(1,2,iobs) = prodatqc%mi(jobs,2)-1 + igrdj2(1,2,iobs) = prodatqc%mj(jobs,2) + igrdi2(2,1,iobs) = prodatqc%mi(jobs,2) + igrdj2(2,1,iobs) = prodatqc%mj(jobs,2)-1 + igrdi2(2,2,iobs) = prodatqc%mi(jobs,2) + igrdj2(2,2,iobs) = prodatqc%mj(jobs,2) + END DO + + ! Initialise depth arrays + zgdept(:,:,:,:) = 0.0 + zgdepw(:,:,:,:) = 0.0 + + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, plam1, zglam1 ) + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi1, igrdj1, pphi1, zgphi1 ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pmask1, zmask1 ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pvar1, zint1 ) + + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, plam2, zglam2 ) + CALL obs_int_comm_2d( 2, 2, ipro, kpi, kpj, igrdi2, igrdj2, pphi2, zgphi2 ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pmask2, zmask2 ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, pvar2, zint2 ) + + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdept, zgdept ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, pgdepw, zgdepw ) + + ! At the end of the day also get interpolated means + IF ( ld_dailyav .AND. idayend == 0 ) THEN + + ALLOCATE( & + & zinm1(2,2,kpk,ipro), & + & zinm2(2,2,kpk,ipro) & + & ) + + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi1, igrdj1, & + & prodatqc%vdmean(:,:,:,1), zinm1 ) + CALL obs_int_comm_3d( 2, 2, ipro, kpi, kpj, kpk, igrdi2, igrdj2, & + & prodatqc%vdmean(:,:,:,2), zinm2 ) + + 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,1) > 0 ) THEN + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam1(:,:,iobs), zgphi1(:,:,iobs), & + & zmask1(:,:,1,iobs), zweig1, zmsk_1 ) + + ENDIF + + IF ( prodatqc%npvend(jobs,2) > 0 ) THEN + + CALL obs_int_h2d_init( 1, 1, k2dint, zlam, zphi, & + & zglam2(:,:,iobs), zgphi2(:,:,iobs), & + & zmask2(:,:,1,iobs), zweig2, zmsk_2 ) + + ENDIF + + IF ( prodatqc%npvend(jobs,1) > 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,1) + iend = prodatqc%npvend(jobs,1) + 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, & + & zinm1(iin,ijn,:,iobs), & + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask1(iin,ijn,:,iobs)) + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs), & + & inum_obs, prodatqc%var(1)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(1)%vdep(ista:iend), & + & zinm1(iin,ijn,:,iobs), & + & zobs2k, interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask1(iin,ijn,:,iobs)) + + ENDDO + ENDDO + + ENDIF !idayend + + ELSE + + ! Point data + + ! vertically interpolate all 4 corners + ista = prodatqc%npvsta(jobs,1) + iend = prodatqc%npvend(jobs,1) + 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, & + & zint1(iin,ijn,:,iobs),& + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask1(iin,ijn,:,iobs)) + + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs),& + & inum_obs, prodatqc%var(1)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(1)%vdep(ista:iend), & + & zint1(iin,ijn,:,iobs), & + & zobs2k,interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask1(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_loop1: DO ik=kpk,2,-1 + IF(zmask1(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(1)%vdep(iend)),0._wp) + + EXIT depth_loop1 + + ENDIF + + ENDDO depth_loop1 + + ENDDO + ENDDO + + CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & + & prodatqc%var(1)%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(1)%nvqc(iend:iend)=4 + + ENDDO + + DEALLOCATE(interp_corner,iv_indic) + + ENDIF + + ! For the second variable + IF ( prodatqc%npvend(jobs,2) > 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,2) + iend = prodatqc%npvend(jobs,2) + 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, & + & zinm2(iin,ijn,:,iobs), & + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask2(iin,ijn,:,iobs)) + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs), & + & inum_obs, prodatqc%var(2)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(2)%vdep(ista:iend), & + & zinm2(iin,ijn,:,iobs), & + & zobs2k, interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask2(iin,ijn,:,iobs)) + + ENDDO + ENDDO + + ENDIF !idayend + + ELSE + + ! Point data + + ! vertically interpolate all 4 corners + ista = prodatqc%npvsta(jobs,2) + iend = prodatqc%npvend(jobs,2) + 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, & + & zint2(iin,ijn,:,iobs),& + & zobs2k, zgdept(iin,ijn,:,iobs), & + & zmask2(iin,ijn,:,iobs)) + + ENDIF + + CALL obs_level_search(kpk, & + & zgdept(iin,ijn,:,iobs),& + & inum_obs, prodatqc%var(2)%vdep(ista:iend), & + & iv_indic) + + CALL obs_int_z1d(kpk, iv_indic, k1dint, inum_obs, & + & prodatqc%var(2)%vdep(ista:iend), & + & zint2(iin,ijn,:,iobs), & + & zobs2k,interp_corner(iin,ijn,:), & + & zgdept(iin,ijn,:,iobs), & + & zmask2(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_loop2: DO ik=kpk,2,-1 + IF(zmask2(iin,ijn,ik-1,iobs ) > 0.9 )THEN + + zweig(iin,ijn,1) = & + & zweig2(iin,ijn,1) * & + & MAX( SIGN(1._wp,(zgdepw(iin,ijn,ik,iobs) ) & + & - prodatqc%var(2)%vdep(iend)),0._wp) + + EXIT depth_loop2 + + ENDIF + + ENDDO depth_loop2 + + ENDDO + ENDDO + + CALL obs_int_h2d( 1, 1, zweig, interp_corner(:,:,ikn), & + & prodatqc%var(2)%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(2)%nvqc(iend:iend)=4 + + ENDDO + + DEALLOCATE(interp_corner,iv_indic) + + ENDIF + + ENDDO + + ! Deallocate the data for interpolation + DEALLOCATE( & + & igrdi1, & + & igrdi2, & + & igrdj1, & + & igrdj2, & + & zglam1, & + & zglam2, & + & zgphi1, & + & zgphi2, & + & zmask1, & + & zmask2, & + & zint1, & + & zint2, & + & zgdept, & + & zgdepw & + & ) + + ! At the end of the day also get interpolated means + IF ( ld_dailyav .AND. idayend == 0 ) THEN + DEALLOCATE( & + & zinm1, & + & zinm2 & + & ) + ENDIF + + prodatqc%nprofup = prodatqc%nprofup + ipro + + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + ! 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 = 1, jpj + DO ji = 1, jpi + ! 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, zobsmask ) + + ! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_prep.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_prep.F90 new file mode 100644 index 0000000..25ef1d2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_prep.F90 @@ -0,0 +1,1451 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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, nproc ! 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_var1, ld_var2, & + & kpi, kpj, kpk, & + & zmask1, pglam1, pgphi1, zmask2, pglam2, pgphi2, & + & ld_nea, ld_bound_reject, 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, & + & nproc + + !! * 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, INTENT(IN) :: ld_var1 ! Observed variables switches + LOGICAL, INTENT(IN) :: ld_var2 + 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, DIMENSION(imaxavtypes), OPTIONAL :: & + & kdailyavtypes ! Types for daily averages + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj,kpk) :: & + & zmask1, & + & zmask2 + REAL(wp), INTENT(IN), DIMENSION(kpi,kpj) :: & + & pglam1, & + & pglam2, & + & pgphi1, & + & pgphi2 + 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 :: iosdv1obs ! - outside space domain (variable 1) + INTEGER :: iosdv2obs ! - outside space domain (variable 2) + INTEGER :: ilanv1obs ! - within a model land cell (variable 1) + INTEGER :: ilanv2obs ! - within a model land cell (variable 2) + INTEGER :: inlav1obs ! - close to land (variable 1) + INTEGER :: inlav2obs ! - close to land (variable 2) + INTEGER :: ibdyv1obs ! - boundary (variable 1) + INTEGER :: ibdyv2obs ! - boundary (variable 2) + INTEGER :: igrdobs ! - fail the grid search + INTEGER :: iuvchku ! - reject u if v rejected and vice versa + INTEGER :: iuvchkv ! + ! Global counters for observations that are + INTEGER :: iotdobsmpp ! - outside time domain + INTEGER :: iosdv1obsmpp ! - outside space domain (variable 1) + INTEGER :: iosdv2obsmpp ! - outside space domain (variable 2) + INTEGER :: ilanv1obsmpp ! - within a model land cell (variable 1) + INTEGER :: ilanv2obsmpp ! - within a model land cell (variable 2) + INTEGER :: inlav1obsmpp ! - close to land (variable 1) + INTEGER :: inlav2obsmpp ! - close to land (variable 2) + INTEGER :: ibdyv1obsmpp ! - boundary (variable 1) + INTEGER :: ibdyv2obsmpp ! - boundary (variable 2) + INTEGER :: igrdobsmpp ! - fail the grid search + INTEGER :: iuvchkumpp ! - reject var1 if var2 rejected and vice versa + INTEGER :: iuvchkvmpp ! + TYPE(obs_prof_valid) :: llvalid ! Profile selection + TYPE(obs_prof_valid), DIMENSION(profdata%nvar) :: & + & llvvalid ! var1,var2 selection + INTEGER :: jvar ! Variable loop variable + INTEGER :: jobs ! Obs. loop variable + INTEGER :: jstp ! Time loop variable + INTEGER :: inrc ! Time index variable + !!---------------------------------------------------------------------- + + 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 + + ! Diagnotics counters for various failures. + + iotdobs = 0 + igrdobs = 0 + iosdv1obs = 0 + iosdv2obs = 0 + ilanv1obs = 0 + ilanv2obs = 0 + inlav1obs = 0 + inlav2obs = 0 + ibdyv1obs = 0 + ibdyv2obs = 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 + ! ----------------------------------------------------------------------- + + CALL obs_coo_grd( profdata%nprof, profdata%mi(:,1), profdata%mj(:,1), & + & profdata%nqc, igrdobs ) + CALL obs_coo_grd( profdata%nprof, profdata%mi(:,2), profdata%mj(:,2), & + & profdata%nqc, igrdobs ) + + 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 + ! ----------------------------------------------------------------------- + + ! Variable 1 + CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(1), & + & profdata%npvsta(:,1), profdata%npvend(:,1), & + & jpi, jpj, & + & jpk, & + & profdata%mi, profdata%mj, & + & profdata%var(1)%mvk, & + & profdata%rlam, profdata%rphi, & + & profdata%var(1)%vdep, & + & pglam1, pgphi1, & + & gdept_1d, zmask1, & + & profdata%nqc, profdata%var(1)%nvqc, & + & iosdv1obs, ilanv1obs, & + & inlav1obs, ld_nea, & + & ibdyv1obs, ld_bound_reject, & + & iqc_cutoff ) + + CALL obs_mpp_sum_integer( iosdv1obs, iosdv1obsmpp ) + CALL obs_mpp_sum_integer( ilanv1obs, ilanv1obsmpp ) + CALL obs_mpp_sum_integer( inlav1obs, inlav1obsmpp ) + CALL obs_mpp_sum_integer( ibdyv1obs, ibdyv1obsmpp ) + + ! Variable 2 + CALL obs_coo_spc_3d( profdata%nprof, profdata%nvprot(2), & + & profdata%npvsta(:,2), profdata%npvend(:,2), & + & jpi, jpj, & + & jpk, & + & profdata%mi, profdata%mj, & + & profdata%var(2)%mvk, & + & profdata%rlam, profdata%rphi, & + & profdata%var(2)%vdep, & + & pglam2, pgphi2, & + & gdept_1d, zmask2, & + & profdata%nqc, profdata%var(2)%nvqc, & + & iosdv2obs, ilanv2obs, & + & inlav2obs, ld_nea, & + & ibdyv2obs, ld_bound_reject, & + & iqc_cutoff ) + + CALL obs_mpp_sum_integer( iosdv2obs, iosdv2obsmpp ) + CALL obs_mpp_sum_integer( ilanv2obs, ilanv2obsmpp ) + CALL obs_mpp_sum_integer( inlav2obs, inlav2obsmpp ) + CALL obs_mpp_sum_integer( ibdyv2obs, ibdyv2obsmpp ) + + ! ----------------------------------------------------------------------- + ! 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 + WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data outside space domain = ', & + & iosdv1obsmpp + WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data at land points = ', & + & ilanv1obsmpp + IF (ld_nea) THEN + WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (removed) = ',& + & inlav1obsmpp + ELSE + WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near land points (kept) = ',& + & inlav1obsmpp + ENDIF + IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN + WRITE(numout,*) ' U observation rejected since V rejected = ', & + & iuvchku + ENDIF + WRITE(numout,*) ' Remaining '//prodatqc%cvars(1)//' data near open boundary (removed) = ',& + & ibdyv1obsmpp + WRITE(numout,*) ' '//prodatqc%cvars(1)//' data accepted = ', & + & prodatqc%nvprotmpp(1) + WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data outside space domain = ', & + & iosdv2obsmpp + WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data at land points = ', & + & ilanv2obsmpp + IF (ld_nea) THEN + WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (removed) = ',& + & inlav2obsmpp + ELSE + WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near land points (kept) = ',& + & inlav2obsmpp + ENDIF + IF ( TRIM(profdata%cvars(1)) == 'UVEL' ) THEN + WRITE(numout,*) ' V observation rejected since U rejected = ', & + & iuvchkv + ENDIF + WRITE(numout,*) ' Remaining '//prodatqc%cvars(2)//' data near open boundary (removed) = ',& + & ibdyv2obsmpp + WRITE(numout,*) ' '//prodatqc%cvars(2)//' data accepted = ', & + & prodatqc%nvprotmpp(2) + + WRITE(numout,*) + WRITE(numout,*) ' Number of observations per time step :' + WRITE(numout,*) + WRITE(numout,'(10X,A,5X,A,5X,A,A)')'Time step','Profiles', & + & ' '//prodatqc%cvars(1)//' ', & + & ' '//prodatqc%cvars(2)//' ' + WRITE(numout,998) + 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(numout,999) jstp, prodatqc%npstpmpp(inrc), & + & prodatqc%nvstpmpp(inrc,1), & + & prodatqc%nvstpmpp(inrc,2) + END DO + ENDIF + +998 FORMAT(10X,'---------',5X,'--------',5X,'-----------',5X,'----------------') +999 FORMAT(10X,I9,5X,I8,5X,I11,5X,I8) + + 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 + & rdt + 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 / rdt ) + + !--------------------------------------------------------------------- + ! 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 / rdt + 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 + + 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 ) + !!---------------------------------------------------------------------- + !! *** 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, ONLY : & ! Geographical information + & gdepw_1d, & + & gdepw_0, & + & gdepw_n, & + & gdept_n, & + & ln_zco, & + & ln_zps + + !! * 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 + + !! * 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 + 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 ) + CALL obs_int_comm_3d( 2, 2, kprofno, kpi, kpj, kpk, igrdi, igrdj, gdepw_n(:,:,:), & + & 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_profiles.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_profiles.F90 new file mode 100644 index 0000000..616d5bc --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_profiles.F90 @@ -0,0 +1,39 @@ +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$ + !! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_profiles_def.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_profiles_def.F90 new file mode 100644 index 0000000..4e41b0f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_profiles_def.F90 @@ -0,0 +1,928 @@ +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$ + !! 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 :: 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 :: 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_altbias.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_altbias.F90 new file mode 100644 index 0000000..84abcee --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_altbias.F90 @@ -0,0 +1,204 @@ +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, & + & jpim1 + 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 + & sshn + 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$ + !! 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_data, 'altbias', z_altbias(:,:), 1 ) + + ! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_prof.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_prof.F90 new file mode 100644 index 0000000..a4bbb8d --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_prof.F90 @@ -0,0 +1,866 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_prof( profdata, knumfiles, cdfilenames, & + & kvars, kextr, kstp, ddobsini, ddobsend, & + & ldvar1, ldvar2, ldignmis, ldsatt, & + & ldmod, 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, INTENT(IN) :: ldvar1 ! Observed variables switches + LOGICAL, INTENT(IN) :: ldvar2 + 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 + 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 :: clvars + 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 :: ivar1t0 + INTEGER :: ivar2t0 + INTEGER :: ivar1t + INTEGER :: ivar2t + INTEGER :: ip3dt + INTEGER :: ios + INTEGER :: ioserrcount + INTEGER :: ivar1tmpp + INTEGER :: ivar2tmpp + INTEGER :: ip3dtmpp + INTEGER :: itype + INTEGER, DIMENSION(knumfiles) :: & + & irefdate + INTEGER, DIMENSION(ntyp1770+1) :: & + & itypvar1, & + & itypvar1mpp, & + & itypvar2, & + & itypvar2mpp + INTEGER, DIMENSION(:), ALLOCATABLE :: & + & iobsi1, & + & iobsj1, & + & iproc1, & + & iobsi2, & + & iobsj2, & + & iproc2, & + & iindx, & + & ifileidx, & + & iprofidx + INTEGER, DIMENSION(imaxavtypes) :: & + & idailyavtypes + INTEGER, DIMENSION(kvars) :: & + & iv3dt + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zphi, & + & zlam + REAL(wp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(wp), DIMENSION(knumfiles) :: & + & djulini, & + & djulend + LOGICAL :: llvalprof + LOGICAL :: lldavtimset + TYPE(obfbdata), POINTER, DIMENSION(:) :: & + & inpfiles + + ! Local initialization + iprof = 0 + ivar1t0 = 0 + ivar2t0 = 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 < 2 ) THEN + CALL ctl_stop( 'Feedback format error: ', & + & ' less than 2 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( clvars( inpfiles(jj)%nvar ) ) + DO ji = 1, inpfiles(jj)%nvar + clvars(ji) = inpfiles(jj)%cname(ji) + END DO + ELSE + DO ji = 1, inpfiles(jj)%nvar + IF ( inpfiles(jj)%cname(ji) /= clvars(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 + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) 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( iobsi1(inowin) ) + ALLOCATE( iobsj1(inowin) ) + ALLOCATE( iproc1(inowin) ) + ALLOCATE( iobsi2(inowin) ) + ALLOCATE( iobsj2(inowin) ) + ALLOCATE( iproc2(inowin) ) + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) 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 + + IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN + CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & + & iproc1, 'T' ) + iobsi2(:) = iobsi1(:) + iobsj2(:) = iobsj1(:) + iproc2(:) = iproc1(:) + ELSEIF ( TRIM( inpfiles(jj)%cname(1) ) == 'UVEL' ) THEN + CALL obs_grid_search( inowin, zlam, zphi, iobsi1, iobsj1, & + & iproc1, 'U' ) + CALL obs_grid_search( inowin, zlam, zphi, iobsi2, iobsj2, & + & iproc2, 'V' ) + ENDIF + + inowin = 0 + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + inowin = inowin + 1 + inpfiles(jj)%iproc(ji,1) = iproc1(inowin) + inpfiles(jj)%iobsi(ji,1) = iobsi1(inowin) + inpfiles(jj)%iobsj(ji,1) = iobsj1(inowin) + inpfiles(jj)%iproc(ji,2) = iproc2(inowin) + inpfiles(jj)%iobsi(ji,2) = iobsi2(inowin) + inpfiles(jj)%iobsj(ji,2) = iobsj2(inowin) + IF ( inpfiles(jj)%iproc(ji,1) /= & + & inpfiles(jj)%iproc(ji,2) ) THEN + CALL ctl_stop( 'Error in obs_read_prof:', & + & 'var1 and var2 observation on different processors') + ENDIF + ENDIF + END DO + DEALLOCATE( zlam, zphi, iobsi1, iobsj1, iproc1, iobsi2, iobsj2, iproc2 ) + + DO ji = 1, inpfiles(jj)%nobs + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + IF ( nproc == 0 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > nproc ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE + ENDIF + llvalprof = .FALSE. + IF ( ldvar1 ) THEN + loop_t_count : DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + ivar1t0 = ivar1t0 + 1 + ENDIF + END DO loop_t_count + ENDIF + IF ( ldvar2 ) THEN + loop_s_count : DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + ivar2t0 = ivar2t0 + 1 + ENDIF + END DO loop_s_count + ENDIF + loop_p_count : DO ij = 1,inpfiles(jj)%nlev + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar1 ) .OR. & + & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar2 ) ) THEN + ip3dt = ip3dt + 1 + llvalprof = .TRUE. + ENDIF + END DO loop_p_count + + 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 + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) 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 + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) 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(1) = ip3dt + iv3dt(2) = ip3dt + ELSE + iv3dt(1) = ivar1t0 + iv3dt(2) = ivar2t0 + 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(:) = clvars(:) + iprof = 0 + + ip3dt = 0 + ivar1t = 0 + ivar2t = 0 + itypvar1 (:) = 0 + itypvar1mpp(:) = 0 + + itypvar2 (:) = 0 + itypvar2mpp(:) = 0 + + ioserrcount = 0 + DO jk = 1, iproftot + + jj = ifileidx(iindx(jk)) + ji = iprofidx(iindx(jk)) + + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE + + IF ( ( inpfiles(jj)%ptim(ji) > djulini(jj) ) .AND. & + & ( inpfiles(jj)%ptim(ji) <= djulend(jj) ) ) THEN + + IF ( nproc == 0 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > nproc ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) CYCLE + ENDIF + + llvalprof = .FALSE. + + IF ( inpfiles(jj)%ioqc(ji) > 2 ) CYCLE + + IF ( BTEST(inpfiles(jj)%ioqc(ji),2 ) ) CYCLE + IF ( BTEST(inpfiles(jj)%ivqc(ji,1),2) .AND. & + & BTEST(inpfiles(jj)%ivqc(ji,2),2) ) CYCLE + + loop_prof : DO ij = 1, inpfiles(jj)%nlev + + IF ( inpfiles(jj)%pdep(ij,ji) >= 6000. ) & + & CYCLE + + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + + llvalprof = .TRUE. + EXIT loop_prof + + ENDIF + + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + + llvalprof = .TRUE. + EXIT loop_prof + + ENDIF + + 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 + profdata%mi (iprof,1) = inpfiles(jj)%iobsi(ji,1) + profdata%mj (iprof,1) = inpfiles(jj)%iobsj(ji,1) + profdata%mi (iprof,2) = inpfiles(jj)%iobsi(ji,2) + profdata%mj (iprof,2) = inpfiles(jj)%iobsj(ji,2) + + ! 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 + + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar1 ) .OR. & + & ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar2 ) ) THEN + ip3dt = ip3dt + 1 + ELSE + CYCLE + ENDIF + + ENDIF + + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar1 ) .OR. ldsatt ) THEN + + IF (ldsatt) THEN + + ivar1t = ip3dt + + ELSE + + ivar1t = ivar1t + 1 + + ENDIF + + ! Depth of var1 observation + profdata%var(1)%vdep(ivar1t) = & + & inpfiles(jj)%pdep(ij,ji) + + ! Depth of var1 observation QC + profdata%var(1)%idqc(ivar1t) = & + & inpfiles(jj)%idqc(ij,ji) + + ! Depth of var1 observation QC flags + profdata%var(1)%idqcf(:,ivar1t) = & + & inpfiles(jj)%idqcf(:,ij,ji) + + ! Profile index + profdata%var(1)%nvpidx(ivar1t) = iprof + + ! Vertical index in original profile + profdata%var(1)%nvlidx(ivar1t) = ij + + ! Profile var1 value + IF ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,1),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) THEN + profdata%var(1)%vobs(ivar1t) = & + & inpfiles(jj)%pob(ij,ji,1) + IF ( ldmod ) THEN + profdata%var(1)%vmod(ivar1t) = & + & inpfiles(jj)%padd(ij,ji,1,1) + ENDIF + ! Count number of profile var1 data as function of type + itypvar1( profdata%ntyp(iprof) + 1 ) = & + & itypvar1( profdata%ntyp(iprof) + 1 ) + 1 + ELSE + profdata%var(1)%vobs(ivar1t) = fbrmdi + ENDIF + + ! Profile var1 qc + profdata%var(1)%nvqc(ivar1t) = & + & inpfiles(jj)%ivlqc(ij,ji,1) + + ! Profile var1 qc flags + profdata%var(1)%nvqcf(:,ivar1t) = & + & inpfiles(jj)%ivlqcf(:,ij,ji,1) + + ! Profile insitu T value + IF ( TRIM( inpfiles(jj)%cname(1) ) == 'POTM' ) THEN + profdata%var(1)%vext(ivar1t,1) = & + & inpfiles(jj)%pext(ij,ji,1) + ENDIF + + ENDIF + + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) .AND. & + & .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) .AND. & + & ldvar2 ) .OR. ldsatt ) THEN + + IF (ldsatt) THEN + + ivar2t = ip3dt + + ELSE + + ivar2t = ivar2t + 1 + + ENDIF + + ! Depth of var2 observation + profdata%var(2)%vdep(ivar2t) = & + & inpfiles(jj)%pdep(ij,ji) + + ! Depth of var2 observation QC + profdata%var(2)%idqc(ivar2t) = & + & inpfiles(jj)%idqc(ij,ji) + + ! Depth of var2 observation QC flags + profdata%var(2)%idqcf(:,ivar2t) = & + & inpfiles(jj)%idqcf(:,ij,ji) + + ! Profile index + profdata%var(2)%nvpidx(ivar2t) = iprof + + ! Vertical index in original profile + profdata%var(2)%nvlidx(ivar2t) = ij + + ! Profile var2 value + IF ( ( .NOT. BTEST(inpfiles(jj)%ivlqc(ij,ji,2),2) ) .AND. & + & ( .NOT. BTEST(inpfiles(jj)%idqc(ij,ji),2) ) ) THEN + profdata%var(2)%vobs(ivar2t) = & + & inpfiles(jj)%pob(ij,ji,2) + IF ( ldmod ) THEN + profdata%var(2)%vmod(ivar2t) = & + & inpfiles(jj)%padd(ij,ji,1,2) + ENDIF + ! Count number of profile var2 data as function of type + itypvar2( profdata%ntyp(iprof) + 1 ) = & + & itypvar2( profdata%ntyp(iprof) + 1 ) + 1 + ELSE + profdata%var(2)%vobs(ivar2t) = fbrmdi + ENDIF + + ! Profile var2 qc + profdata%var(2)%nvqc(ivar2t) = & + & inpfiles(jj)%ivlqc(ij,ji,2) + + ! Profile var2 qc flags + profdata%var(2)%nvqcf(:,ivar2t) = & + & inpfiles(jj)%ivlqcf(:,ij,ji,2) + + ENDIF + + END DO loop_p + + ENDIF + + ENDIF + + END DO + + !----------------------------------------------------------------------- + ! Sum up over processors + !----------------------------------------------------------------------- + + CALL obs_mpp_sum_integer ( ivar1t0, ivar1tmpp ) + CALL obs_mpp_sum_integer ( ivar2t0, ivar2tmpp ) + CALL obs_mpp_sum_integer ( ip3dt, ip3dtmpp ) + + CALL obs_mpp_sum_integers( itypvar1, itypvar1mpp, ntyp1770 + 1 ) + CALL obs_mpp_sum_integers( itypvar2, itypvar2mpp, ntyp1770 + 1 ) + + !----------------------------------------------------------------------- + ! Output number of observations. + !----------------------------------------------------------------------- + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,'(A)') ' Profile data' + WRITE(numout,'(1X,A)') '------------' + WRITE(numout,*) + WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(1) ) + WRITE(numout,'(1X,A)') '------------------------' + DO ji = 0, ntyp1770 + IF ( itypvar1mpp(ji+1) > 0 ) THEN + WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & + & cwmonam1770(ji)(1:52),' = ', & + & itypvar1mpp(ji+1) + ENDIF + END DO + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,'(1X,A55,I8)') & + & 'Total profile data for variable '//TRIM( profdata%cvars(1) )// & + & ' = ', ivar1tmpp + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,*) + WRITE(numout,'(1X,A)') 'Profile data, '//TRIM( profdata%cvars(2) ) + WRITE(numout,'(1X,A)') '------------------------' + DO ji = 0, ntyp1770 + IF ( itypvar2mpp(ji+1) > 0 ) THEN + WRITE(numout,'(1X,A3,1X,A48,A3,I8)') ctypshort(ji), & + & cwmonam1770(ji)(1:52),' = ', & + & itypvar2mpp(ji+1) + ENDIF + END DO + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,'(1X,A55,I8)') & + & 'Total profile data for variable '//TRIM( profdata%cvars(2) )// & + & ' = ', ivar2tmpp + WRITE(numout,'(1X,A)') & + & '---------------------------------------------------------------' + WRITE(numout,*) + ENDIF + + IF (ldsatt) THEN + profdata%nvprot(1) = ip3dt + profdata%nvprot(2) = ip3dt + profdata%nvprotmpp(1) = ip3dtmpp + profdata%nvprotmpp(2) = ip3dtmpp + ELSE + profdata%nvprot(1) = ivar1t + profdata%nvprot(2) = ivar2t + profdata%nvprotmpp(1) = ivar1tmpp + profdata%nvprotmpp(2) = ivar2tmpp + ENDIF + profdata%nprof = iprof + + !----------------------------------------------------------------------- + ! Model level search + !----------------------------------------------------------------------- + IF ( ldvar1 ) THEN + CALL obs_level_search( jpk, gdept_1d, & + & profdata%nvprot(1), profdata%var(1)%vdep, & + & profdata%var(1)%mvk ) + ENDIF + IF ( ldvar2 ) THEN + CALL obs_level_search( jpk, gdept_1d, & + & profdata%nvprot(2), profdata%var(2)%vdep, & + & profdata%var(2)%mvk ) + ENDIF + + !----------------------------------------------------------------------- + ! 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, clvars ) + + !----------------------------------------------------------------------- + ! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_surf.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_surf.F90 new file mode 100644 index 0000000..208a72b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_read_surf.F90 @@ -0,0 +1,496 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE obs_rea_surf( surfdata, knumfiles, cdfilenames, & + & kvars, kextr, kstp, ddobsini, ddobsend, & + & ldignmis, ldmod, ldnightav ) + !!--------------------------------------------------------------------- + !! + !! *** 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(dp), INTENT(IN) :: ddobsini ! Obs. ini time in YYYYMMDD.HHMMSS + REAL(dp), INTENT(IN) :: ddobsend ! Obs. end time in YYYYMMDD.HHMMSS + + !! * Local declarations + CHARACTER(LEN=11), PARAMETER :: cpname='obs_rea_surf' + CHARACTER(len=8) :: clrefdate + CHARACTER(len=8), DIMENSION(:), ALLOCATABLE :: clvars + 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(wp), DIMENSION(:), ALLOCATABLE :: & + & zdat + REAL(wp), 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 ( ldmod .AND. ( inpfiles(jj)%nadd == 0 ) ) THEN + CALL ctl_stop( 'Model not in input data' ) + RETURN + ENDIF + + IF ( jj == 1 ) THEN + ALLOCATE( clvars( inpfiles(jj)%nvar ) ) + DO ji = 1, inpfiles(jj)%nvar + clvars(ji) = inpfiles(jj)%cname(ji) + END DO + ELSE + DO ji = 1, inpfiles(jj)%nvar + IF ( inpfiles(jj)%cname(ji) /= clvars(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 ( nproc == 0 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > nproc ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) 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(:) = clvars(:) + + 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 ( nproc == 0 ) THEN + IF ( inpfiles(jj)%iproc(ji,1) > nproc ) CYCLE + ELSE + IF ( inpfiles(jj)%iproc(ji,1) /= nproc ) 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, clvars ) + + !----------------------------------------------------------------------- + ! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_readmdt.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_readmdt.F90 new file mode 100644 index 0000000..36b1007 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_readmdt.F90 @@ -0,0 +1,258 @@ +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 : sshn ! 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE obs_rea_mdt( sladata, k2dint ) + !!--------------------------------------------------------------------- + !! + !! *** 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 ! ? + ! + 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_data, 'sossheig', z_mdt(:,:), 1 ) + 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 ) + + ! 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 ) + !!--------------------------------------------------------------------- + !! + !! *** 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 + 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 = 1, jpj + DO ji = 1, jpi + zdxdy = e1e2t(ji,jj) * zpromsk(ji,jj) + zarea = zarea + zdxdy + zeta1 = zeta1 + mdt(ji,jj) * zdxdy + zeta2 = zeta2 + sshn (ji,jj) * 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_rot_vel.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_rot_vel.F90 new file mode 100644 index 0000000..a6729ad --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_rot_vel.F90 @@ -0,0 +1,228 @@ +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$ + !! 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', __LINE__ ) + 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_sort.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_sort.F90 new file mode 100644 index 0000000..6540252 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_sort.F90 @@ -0,0 +1,147 @@ +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$ + !! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_sstbias.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_sstbias.F90 new file mode 100644 index 0000000..ffa98ba --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_sstbias.F90 @@ -0,0 +1,243 @@ +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, & + & jpim1 + 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 + & sshn + 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_data, '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/NEMO_4.0.4_surge/src/OCE/OBS/obs_surf_def.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_surf_def.F90 new file mode 100644 index 0000000..3a8c05a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_surf_def.F90 @@ -0,0 +1,530 @@ +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$ + !! 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 :: 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 :: 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_types.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_types.F90 new file mode 100644 index 0000000..08e08ec --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_types.F90 @@ -0,0 +1,267 @@ +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$ + !! 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/NEMO_4.0.4_surge/src/OCE/OBS/obs_utils.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_utils.F90 new file mode 100644 index 0000000..f3177e9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_utils.F90 @@ -0,0 +1,213 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + +#include "grt_cir_dis.h90" + +#include "grt_cir_dis_saa.h90" + +#include "str_c_to_for.h90" + + 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 + USE dom_oce, ONLY : & ! Ocean space and time domain variables + & nproc + + !! * Arguments + INTEGER :: kstatus + INTEGER :: klineno + CHARACTER(LEN=*) :: 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 + USE dom_oce, ONLY : & ! Ocean space and time domain variables + & nproc + + !! * 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 :: 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 :: 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 + +#include "ddatetoymdhms.h90" + +END MODULE obs_utils diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obs_write.F90 b/NEMO_4.0.4_surge/src/OCE/OBS/obs_write.F90 new file mode 100644 index 0000000..320a62e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obs_write.F90 @@ -0,0 +1,608 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + 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, 2 + 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 + + fbdata%caddname(1) = 'Hx' + + WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc + + 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, 2 + 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=12), PARAMETER :: cpname = 'obs_wri_surf' + 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') + + 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') + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 1 + iadd, iext, .TRUE. ) + + clfiletype = 'sstfb' + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = 'Sea surface temperature' + fbdata%cobunit(1) = 'Degree centigrade' + 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 SST' + fbdata%caddunit(1,1) = 'Degree centigrade' + fbdata%cgrid(1) = 'T' + 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 + + CASE('ICECONC') + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 1 + iadd, iext, .TRUE. ) + + clfiletype = 'sicfb' + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = 'Sea ice' + fbdata%cobunit(1) = 'Fraction' + 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 ICE' + fbdata%caddunit(1,1) = 'Fraction' + fbdata%cgrid(1) = 'T' + 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 + + CASE('SSS') + + CALL alloc_obfbdata( fbdata, 1, surfdata%nsurf, 1, & + & 1 + iadd, iext, .TRUE. ) + + clfiletype = 'sssfb' + fbdata%cname(1) = surfdata%cvars(1) + fbdata%coblong(1) = 'Sea surface salinity' + fbdata%cobunit(1) = 'psu' + 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 SSS' + fbdata%caddunit(1,1) = 'psu' + fbdata%cgrid(1) = 'T' + 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 + + CASE DEFAULT + + CALL ctl_stop( 'Unknown observation type '//TRIM(surfdata%cvars(1))//' in obs_wri_surf' ) + + END SELECT + + fbdata%caddname(1) = 'Hx' + + WRITE(clfname, FMT="(A,'_fdbk_',I4.4,'.nc')") TRIM(clfiletype), nproc + + 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/NEMO_4.0.4_surge/src/OCE/OBS/obsinter_h2d.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/obsinter_h2d.h90 new file mode 100644 index 0000000..291ae27 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obsinter_h2d.h90 @@ -0,0 +1,1359 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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)))<iminpoints) CYCLE + ENDIF + zsum(jk) = z2dmm(jk) + z2dmp(jk) + z2dpm(jk) + z2dpp(jk) + IF ( zsum(jk) /= 0.0_wp ) THEN + pweig(1,1,jk) = z2dmm(jk) + pweig(1,2,jk) = z2dmp(jk) + pweig(2,1,jk) = z2dpm(jk) + pweig(2,2,jk) = z2dpp(jk) + ! Set the vertical mask + IF ( ( ( z2dmm(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 diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/obsinter_z1d.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/obsinter_z1d.h90 new file mode 100644 index 0000000..66af1bb --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/obsinter_z1d.h90 @@ -0,0 +1,191 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ( pobsmask(kkco(jdep)) == 0.0_wp ) z1dp = 0.0_wp + + 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 + 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 + + diff --git a/NEMO_4.0.4_surge/src/OCE/OBS/str_c_to_for.h90 b/NEMO_4.0.4_surge/src/OCE/OBS/str_c_to_for.h90 new file mode 100644 index 0000000..da0a1d9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/OBS/str_c_to_for.h90 @@ -0,0 +1,39 @@ + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/cpl_oasis3.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/cpl_oasis3.F90 new file mode 100644 index 0000000..bff5242 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/cpl_oasis3.F90 @@ -0,0 +1,634 @@ +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 + !! 'key_oa3mct_v3' to be added for OASIS3-MCT version 3 + !!---------------------------------------------------------------------- + !! 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 + !!---------------------------------------------------------------------- +#if defined key_oasis3 + USE mod_oasis ! OASIS3-MCT module +#endif +#if defined key_iomput && defined key_xios25 + USE xios, ONLY:xios_oasis_enddef +#endif + 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 +#if ! defined key_oasis3 + ! 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 +#endif + + 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=60 ! 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 + LOGICAL, PARAMETER :: ltmp_wapatch = .TRUE. ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define + INTEGER :: nldi_save, nlei_save + INTEGER :: nldj_save, nlej_save + + 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$ + !! 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 OPA 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 + !!-------------------------------------------------------------------- + + ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define + IF ( ltmp_wapatch ) THEN + nldi_save = nldi ; nlei_save = nlei + nldj_save = nldj ; nlej_save = nlej + IF( nimpp == 1 ) nldi = 1 + IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi + IF( njmpp == 1 ) nldj = 1 + IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj + ENDIF + 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 + ! For serial configuration (key_mpp_mpi not being active) + ! nl* is set to the global values 1 and jp*glo. + ! + ishape(1) = 1 + ishape(2) = nlei-nldi+1 + ishape(3) = 1 + ishape(4) = nlej-nldj+1 + ! + ! ... Allocate memory for data exchange + ! + ALLOCATE(exfld(nlei-nldi+1, nlej-nldj+1), stat = nerror) + IF( nerror > 0 ) THEN + CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in allocating exfld') ; RETURN + ENDIF + ! + ! ----------------------------------------------------------------- + ! ... Define the partition + ! ----------------------------------------------------------------- + + paral(1) = 2 ! box partitioning + paral(2) = jpiglo * (nldj-1+njmpp-1) + (nldi-1+nimpp-1) ! NEMO lower left corner global offset + paral(3) = nlei-nldi+1 ! local extent in i + paral(4) = nlej-nldj+1 ! local extent in j + paral(5) = jpiglo ! global extent in x + + IF( ln_ctl ) THEN + WRITE(numout,*) ' multiexchg: paral (1:5)', paral + WRITE(numout,*) ' multiexchg: jpi, jpj =', jpi, jpj + WRITE(numout,*) ' multiexchg: nldi, nlei, nimpp =', nldi, nlei, nimpp + WRITE(numout,*) ' multiexchg: nldj, nlej, njmpp =', nldj, nlej, njmpp + ENDIF + + CALL oasis_def_partition ( id_part, paral, nerror, jpiglo*jpjglo ) + ! + ! ... 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 defined key_agrif + IF( agrif_fixed() /= 0 ) THEN + zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname) + END IF +#endif + IF( ln_ctl ) 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( ln_ctl .AND. ssnd(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" + IF( ln_ctl .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 defined key_agrif + IF( agrif_fixed() /= 0 ) THEN + zclname=TRIM(Agrif_CFixed())//'_'//TRIM(zclname) + END IF +#endif + IF( ln_ctl ) 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( ln_ctl .AND. srcv(ji)%nid(jc,jm) /= -1 ) WRITE(numout,*) "variable defined in the namcouple" + IF( ln_ctl .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 + !------------------------------------------------------------------ + ! +#if defined key_agrif + IF( agrif_fixed() == Agrif_Nb_Fine_Grids() ) THEN +#endif + ! +#if defined key_iomput && defined key_xios25 +!needed for XIOS 2.5 + CALL xios_oasis_enddef() +#endif + ! + CALL oasis_enddef(nerror) + IF( nerror /= OASIS_Ok ) CALL oasis_abort ( ncomp_id, 'cpl_define', 'Failure in oasis_enddef') +#if defined key_agrif + ENDIF +#endif + ! + IF ( ltmp_wapatch ) THEN + nldi = nldi_save ; nlei = nlei_save + nldj = nldj_save ; nlej = nlej_save + ENDIF + 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 + !!-------------------------------------------------------------------- + ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define + IF ( ltmp_wapatch ) THEN + nldi_save = nldi ; nlei_save = nlei + nldj_save = nldj ; nlej_save = nlej + IF( nimpp == 1 ) nldi = 1 + IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi + IF( njmpp == 1 ) nldj = 1 + IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj + ENDIF + ! + ! snd data to OASIS3 + ! + DO jc = 1, ssnd(kid)%nct + DO jm = 1, ssnd(kid)%ncplmodel + + IF( ssnd(kid)%nid(jc,jm) /= -1 ) THEN + CALL oasis_put ( ssnd(kid)%nid(jc,jm), kstep, pdata(nldi:nlei, nldj:nlej,jc), kinfo ) + + IF ( ln_ctl ) 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(nldi:nlei,nldj:nlej,jc)) + WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(nldi:nlei,nldj:nlej,jc)) + WRITE(numout,*) ' - Sum value is ', SUM(pdata(nldi:nlei,nldj:nlej,jc)) + WRITE(numout,*) '****************' + ENDIF + ENDIF + + ENDIF + + ENDDO + ENDDO + IF ( ltmp_wapatch ) THEN + nldi = nldi_save ; nlei = nlei_save + nldj = nldj_save ; nlej = nlej_save + ENDIF + ! + 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, llfisrt + !!-------------------------------------------------------------------- + ! patch to restore wraparound rows in cpl_send, cpl_rcv, cpl_define + IF ( ltmp_wapatch ) THEN + nldi_save = nldi ; nlei_save = nlei + nldj_save = nldj ; nlej_save = nlej + ENDIF + ! + ! receive local data from OASIS3 on every process + ! + kinfo = OASIS_idle + ! + DO jc = 1, srcv(kid)%nct + IF ( ltmp_wapatch ) THEN + IF( nimpp == 1 ) nldi = 1 + IF( nimpp + jpi - 1 == jpiglo ) nlei = jpi + IF( njmpp == 1 ) nldj = 1 + IF( njmpp + jpj - 1 == jpjglo ) nlej = jpj + ENDIF + llfisrt = .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 ( ln_ctl ) WRITE(numout,*) "llaction, kinfo, kstep, ivarid: " , llaction, kinfo, kstep, srcv(kid)%nid(jc,jm) + + IF ( llaction ) THEN + + kinfo = OASIS_Rcv + IF( llfisrt ) THEN + pdata(nldi:nlei,nldj:nlej,jc) = exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) + llfisrt = .FALSE. + ELSE + pdata(nldi:nlei,nldj:nlej,jc) = pdata(nldi:nlei,nldj:nlej,jc) + exfld(:,:) * pmask(nldi:nlei,nldj:nlej,jm) + ENDIF + + IF ( ln_ctl ) 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(nldi:nlei,nldj:nlej,jc)) + WRITE(numout,*) ' - Maximum value is ', MAXVAL(pdata(nldi:nlei,nldj:nlej,jc)) + WRITE(numout,*) ' - Sum value is ', SUM(pdata(nldi:nlei,nldj:nlej,jc)) + WRITE(numout,*) '****************' + ENDIF + + ENDIF + + ENDIF + + ENDDO + + IF ( ltmp_wapatch ) THEN + nldi = nldi_save ; nlei = nlei_save + nldj = nldj_save ; nlej = nlej_save + ENDIF + !--- Fill the overlap areas and extra hallows (mpp) + !--- check periodicity conditions (all cases) + IF( .not. llfisrt ) 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 +#if ! defined key_oa3mct_v1v2 + CALL oasis_get_freqs(id, mop, 1, itmp, info) +#else + CALL oasis_get_freqs(id, 1, itmp, info) +#endif + 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 + +#if ! defined key_oasis3 + + !!---------------------------------------------------------------------- + !! 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 + +#endif + + !!===================================================================== +END MODULE cpl_oasis3 diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/cyclone.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/cyclone.F90 new file mode 100644 index 0000000..0392a0f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/cyclone.F90 @@ -0,0 +1,275 @@ +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 + !!---------------------------------------------------------------------- + +#if defined key_cyclone + !!---------------------------------------------------------------------- + !! 'key_cyclone' : key option add Tropical Cyclones in the wind forcing + !!---------------------------------------------------------------------- + !! wnd_cyc : 1 module subroutine + !!---------------------------------------------------------------------- + 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 fldread ! read input fields + USE in_out_manager ! I/O manager + USE geo2ocean ! tools for projection on ORCA grid + USE lib_mpp + + IMPLICIT NONE + PRIVATE + + PUBLIC wnd_cyc ! routine called in sbcblk.F90 module + + INTEGER , PARAMETER :: jp_is1 = 1 ! index of presence 1 or absence 0 of a TC record + INTEGER , PARAMETER :: jp_lon = 2 ! index of longitude for present TCs + INTEGER , PARAMETER :: jp_lat = 3 ! index of latitude for present TCs + INTEGER , PARAMETER :: jp_vmax = 4 ! index of max wind for present TCs + INTEGER , PARAMETER :: jp_pres = 5 ! index of eye-pres for present TCs + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + +CONTAINS + + SUBROUTINE wnd_cyc( kt, pwnd_i, pwnd_j ) + !!---------------------------------------------------------------------- + !! *** ROUTINE wnd_cyc *** + !! + !! ** Purpose : Add cyclone winds on the ORCA grid + !! + !! ** Action : - open TC data, find TCs for the current timestep + !! - for each potential TC, add the winds on the grid + !!---------------------------------------------------------------------- + INTEGER , INTENT(in) :: kt ! time step index + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_i ! wind speed i-components at T-point ORCA direction + REAL(wp), INTENT(out), DIMENSION(jpi,jpj) :: pwnd_j ! wind speed j-components at T-point ORCA direction + ! + !! + INTEGER :: ji, jj , jtc ! loop arguments + INTEGER :: ierror ! loop arguments + INTEGER :: vortex=1 ! vortex shape to be used: 0=Holland 1=Willoughby + REAL(wp) :: zrout1=1.5e6 ! distance from center where we begin to kill vortex (m) + REAL(wp) :: zrout2=2.5e6 ! distance from center where we bring vortex to zero (m) + REAL(wp) :: zb ! power in Holland vortex shape + REAL(wp) :: zA ! shape parameter in Willoughby vortex : A transtion between first and second outter exp + REAL(wp) :: zn ! shape parameter in Willoughby vortex : n power law in the eye + REAL(wp) :: zXX1 ! shape parameter in Willoughby vortex : decay length second outter exponential + REAL(wp) :: zXX2 ! shape parameter in Willoughby vortex : decay length first outter exponential + REAL(wp) :: zztmp ! temporary + REAL(wp) :: zzrglam, zzrgphi ! temporary + REAL(wp) :: ztheta ! azimuthal angle + REAL(wp) :: zdist ! dist to the TC center + REAL(wp) :: zhemi ! 1 for NH ; -1 for SH + REAL(wp) :: zinfl ! clim inflow angle in TCs + REAL(wp) :: zrmw ! mean radius of Max wind of a tropical cyclone (Willoughby 2004) [m] + REAL(wp) :: zwnd_r, zwnd_t ! radial and tangential components of the wind + REAL(wp) :: zvmax ! timestep interpolated vmax + REAL(wp) :: zrlon, zrlat ! temporary + REAL(wp), DIMENSION(jpi,jpj) :: zwnd_x, zwnd_y ! zonal and meridional components of the wind + REAL(wp), DIMENSION(14,5) :: ztct ! tropical cyclone track data at kt + ! + CHARACTER(len=100) :: cn_dir ! Root directory for location of files + TYPE(FLD_N), DIMENSION(1) :: slf_i ! array of namelist informations on the TC position + TYPE(FLD_N) :: sn_tc ! informations about the fields to be read + !!-------------------------------------------------------------------- + + ! ! ====================== ! + IF( kt == nit000 ) THEN ! First call kt=nit000 ! + ! ! ====================== ! + ! set file information (default values) + cn_dir = './' ! directory in which the model is executed + ! + ! (NB: frequency positive => hours, negative => months) + ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! land/sea mask ! + ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! filename ! + sn_tc = FLD_N( 'tc_track', 6 , 'tc' , .true. , .false. , 'yearly' , '' , '' , '' ) + ! + ! Namelist is read in namsbc_blk + ! set sf structure + ALLOCATE( sf(1), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'wnd_cyc: unable to allocate sf structure' ) ; RETURN + ENDIF + ALLOCATE( sf(1)%fnow(14,5,1) ) + ALLOCATE( sf(1)%fdta(14,5,1,2) ) + slf_i(1) = sn_tc + ! + ! fill sf with slf_i and control print + CALL fld_fill( sf, slf_i, cn_dir, 'sbc_blk_tc', 'tropical cyclone track', 'namsbc_tc' ) + ! + ENDIF + + + ! Interpolation of lon lat vmax... at the current timestep + ! *************************************************************** + + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + + ztct(:,:) = sf(1)%fnow(:,:,1) + + ! Add TC wind on the grid + ! *************************************************************** + + zwnd_x(:,:) = 0.e0 + zwnd_y(:,:) = 0.e0 + + DO jtc = 1, 14 + ! + IF( ztct(jtc,jp_is1) == 1 ) THEN ! cyclone is defined in this slot ? yes--> begin + + zvmax = ztct(jtc,jp_vmax) + zrlon = rad * ztct(jtc,jp_lon ) + zrlat = rad * ztct(jtc,jp_lat ) + zhemi = SIGN( 1. , zrlat ) + zinfl = 15.* rad ! clim inflow angle in Tropical Cyclones + IF ( vortex == 0 ) THEN + + ! Vortex Holland reconstruct wind at each lon-lat position + ! ******************************************************** + zrmw = 51.6 * EXP( -0.0223*zvmax + 0.0281* ABS( ztct(jtc,jp_lat) ) ) * 1000. + ! climatological ZRMW of cyclones as a function of wind and latitude (Willoughby 2004) + ! zb = 1.0036 + 0.0173 * zvmax - 0.0313 * LOG(zrmw/1000.) + 0.0087 * ABS( ztct(jtc,jp_lat) ) + ! fitted B parameter (Willoughby 2004) + zb = 2. + + DO jj = 1, jpj + DO ji = 1, jpi + + ! calc distance between TC center and any point following great circle + ! source : http://www.movable-type.co.uk/scripts/latlong.html + zzrglam = rad * glamt(ji,jj) - zrlon + zzrgphi = rad * gphit(ji,jj) + zdist = ra * ACOS( SIN( zrlat ) * SIN( zzrgphi ) & + & + COS( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) ) + + IF (zdist < zrout2) THEN ! calculation of wind only to a given max radius + ! shape of the wind profile + zztmp = ( zrmw / ( zdist + 1.e-12 ) )**zb + zztmp = zvmax * SQRT( zztmp * EXP(1. - zztmp) ) + + IF (zdist > zrout1) THEN ! bring to zero between r_out1 and r_out2 + zztmp = zztmp * ( (zrout2-zdist)*1.e-6 ) + ENDIF + + ! !!! KILL EQ WINDS + ! IF (SIGN( 1. , zrlat ) /= zhemi) THEN + ! zztmp = 0. ! winds in other hemisphere + ! IF (ABS(gphit(ji,jj)) <= 5.) zztmp=0. ! kill between 5N-5S + ! ENDIF + ! IF (ABS(gphit(ji,jj)) <= 10. .and. ABS(gphit(ji,jj)) > 5.) THEN + ! zztmp = zztmp * ( 1./5. * (ABS(gphit(ji,jj)) - 5.) ) + ! !linear to zero between 10 and 5 + ! ENDIF + ! !!! / KILL EQ + + IF (ABS(gphit(ji,jj)) >= 55.) zztmp = 0. ! kill weak spurious winds at high latitude + + zwnd_t = COS( zinfl ) * zztmp + zwnd_r = - SIN( zinfl ) * zztmp + + ! Project radial-tangential components on zonal-meridional components + ! ------------------------------------------------------------------- + + ! ztheta = azimuthal angle of the great circle between two points + zztmp = COS( zrlat ) * SIN( zzrgphi ) & + & - SIN( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) + ztheta = ATAN2( COS( zzrgphi ) * SIN( zzrglam ) , zztmp ) + + zwnd_x(ji,jj) = zwnd_x(ji,jj) - zhemi * COS(ztheta)*zwnd_t + SIN(ztheta)*zwnd_r + zwnd_y(ji,jj) = zwnd_y(ji,jj) + zhemi * SIN(ztheta)*zwnd_t + COS(ztheta)*zwnd_r + ENDIF + END DO + END DO + + ELSE IF ( vortex == 1 ) THEN + + ! Vortex Willoughby reconstruct wind at each lon-lat position + ! *********************************************************** + zrmw = 46.4 * EXP( -0.0155*zvmax + 0.0169* ABS( ztct(jtc,jp_lat) ) )*1000. + ! climatological ZRMW of cyclones as a function of wind and latitude (Willoughby 2006) + zXX2 = 25.*1000. ! 25km fixed "near-eye" exponential decay + zXX1 = ( 287.6 - 1.942 *zvmax + 7.799 *LOG(zrmw/1000.) + 1.819 *ABS( ztct(jtc,jp_lat) ) )*1000. + zn = 2.1340 + 0.0077*zvmax - 0.4522*LOG(zrmw/1000.) - 0.0038*ABS( ztct(jtc,jp_lat) ) + zA = 0.5913 + 0.0029*zvmax - 0.1361*LOG(zrmw/1000.) - 0.0042*ABS( ztct(jtc,jp_lat) ) + IF (zA < 0) THEN + zA=0 + ENDIF + + DO jj = 1, jpj + DO ji = 1, jpi + + zzrglam = rad * glamt(ji,jj) - zrlon + zzrgphi = rad * gphit(ji,jj) + zdist = ra * ACOS( SIN( zrlat ) * SIN( zzrgphi ) & + & + COS( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) ) + + IF (zdist < zrout2) THEN ! calculation of wind only to a given max radius + + ! shape of the wind profile + IF (zdist <= zrmw) THEN ! inside the Radius of Maximum Wind + zztmp = zvmax * (zdist/zrmw)**zn + ELSE + zztmp = zvmax * ( (1-zA) * EXP(- (zdist-zrmw)/zXX1 ) + zA * EXP(- (zdist-zrmw)/zXX2 ) ) + ENDIF + + IF (zdist > zrout1) THEN ! bring to zero between r_out1 and r_out2 + zztmp = zztmp * ( (zrout2-zdist)*1.e-6 ) + ENDIF + + ! !!! KILL EQ WINDS + ! IF (SIGN( 1. , zrlat ) /= zhemi) THEN + ! zztmp = 0. ! winds in other hemisphere + ! IF (ABS(gphit(ji,jj)) <= 5.) zztmp=0. ! kill between 5N-5S + ! ENDIF + ! IF (ABS(gphit(ji,jj)) <= 10. .and. ABS(gphit(ji,jj)) > 5.) THEN + ! zztmp = zztmp * ( 1./5. * (ABS(gphit(ji,jj)) - 5.) ) + ! !linear to zero between 10 and 5 + ! ENDIF + ! !!! / KILL EQ + + IF (ABS(gphit(ji,jj)) >= 55.) zztmp = 0. ! kill weak spurious winds at high latitude + + zwnd_t = COS( zinfl ) * zztmp + zwnd_r = - SIN( zinfl ) * zztmp + + ! Project radial-tangential components on zonal-meridional components + ! ------------------------------------------------------------------- + + ! ztheta = azimuthal angle of the great circle between two points + zztmp = COS( zrlat ) * SIN( zzrgphi ) & + & - SIN( zrlat ) * COS( zzrgphi ) * COS( zzrglam ) + ztheta = ATAN2( COS( zzrgphi ) * SIN( zzrglam ) , zztmp ) + + zwnd_x(ji,jj) = zwnd_x(ji,jj) - zhemi * COS(ztheta)*zwnd_t + SIN(ztheta)*zwnd_r + zwnd_y(ji,jj) = zwnd_y(ji,jj) + zhemi * SIN(ztheta)*zwnd_t + COS(ztheta)*zwnd_r + + ENDIF + END DO + END DO + ENDIF ! / vortex Holland or Wiloughby + ENDIF ! / cyclone is defined in this slot ? yes--> begin + END DO ! / end simultaneous cyclones loop + + CALL rot_rep ( zwnd_x, zwnd_y, 'T', 'en->i', pwnd_i ) !rotation of components on ORCA grid + CALL rot_rep ( zwnd_x, zwnd_y, 'T', 'en->j', pwnd_j ) !rotation of components on ORCA grid + + END SUBROUTINE wnd_cyc + +#endif + + !!====================================================================== +END MODULE cyclone diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/fldread.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/fldread.F90 new file mode 100644 index 0000000..076c7da --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/fldread.F90 @@ -0,0 +1,1762 @@ +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_rec : determined the record(s) to be read + !! 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 : update the data file name and 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 + !! ksec_week : function returning the first 3 letters of the first day of the weekly file + !!---------------------------------------------------------------------- + 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 (C1D case) + + IMPLICIT NONE + PRIVATE + + PUBLIC fld_map ! routine called by tides_init + PUBLIC fld_read, fld_fill ! called by sbc... modules + PUBLIC fld_clopn + + 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) :: cltype ! 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) :: cltype ! type of data file 'daily', 'monthly' or yearly' + INTEGER :: num ! iom id of the jpfld files to be read + INTEGER , DIMENSION(2) :: nrec_b ! before record (1: index, 2: second since Jan. 1st 00h of nit000 year) + INTEGER , DIMENSION(2) :: nrec_a ! after record (1: index, 2: second since Jan. 1st 00h of nit000 year) + REAL(wp) , ALLOCATABLE, DIMENSION(:,:,: ) :: fnow ! input fields interpolated to now time step + REAL(wp) , ALLOCATABLE, 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 + REAL(wp), PARAMETER :: undeff_lsm = -999.00_wp + +!$AGRIF_END_DO_NOT_TREAT + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE fld_read( kt, kn_fsbc, sd, kit, kt_offset ) + !!--------------------------------------------------------------------- + !! *** 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 + INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! provide fields at time other than "now" + ! ! kt_offset = -1 => fields at "before" time level + ! ! kt_offset = +1 => fields at "after" time level + ! ! etc. + !! + INTEGER :: itmp ! local variable + INTEGER :: imf ! size of the structure sd + INTEGER :: jf ! dummy indices + INTEGER :: isecend ! number of second since Jan. 1st 00h of nit000 year at nitend + INTEGER :: isecsbc ! number of seconds between Jan. 1st 00h of nit000 year and the middle of sbc time step + INTEGER :: it_offset ! local time offset variable + LOGICAL :: llnxtyr ! open next year file? + LOGICAL :: llnxtmth ! open next month file? + LOGICAL :: llstop ! stop is the file does not exist + LOGICAL :: ll_firstcall ! true if this is the first call to fld_read for this set of fields + 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 ; it_offset = nn_fsbc + ELSE ; it_offset = 0 + ENDIF + IF( PRESENT(kt_offset) ) it_offset = kt_offset + + ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar + IF( present(kit) ) THEN ! ignore kn_fsbc in this case + isecsbc = nsec_year + nsec1jan000 + (kit+it_offset)*NINT( rdt/REAL(nn_baro,wp) ) + ELSE ! middle of sbc time step + isecsbc = nsec_year + nsec1jan000 + NINT(0.5 * REAL(kn_fsbc - 1,wp) * rdt) + it_offset * NINT(rdt) + ENDIF + imf = SIZE( sd ) + ! + IF( ll_firstcall ) THEN ! initialization + DO jf = 1, imf + IF( TRIM(sd(jf)%clrootname) == 'NOT USED' ) CYCLE + CALL fld_init( kn_fsbc, 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 + + IF( isecsbc > sd(jf)%nrec_a(2) .OR. ll_firstcall ) THEN ! read/update the after data? + + sd(jf)%nrec_b(:) = sd(jf)%nrec_a(:) ! swap before record informations + sd(jf)%rotn(1) = sd(jf)%rotn(2) ! swap before rotate informations + IF( sd(jf)%ln_tint ) sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! swap before record field + + CALL fld_rec( kn_fsbc, sd(jf), kt_offset = it_offset, kit = kit ) ! update after record informations + + ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), + ! it is possible that the before value is no more the good one... we have to re-read it + ! if before is not the last record of the file currently opened and after is the first record to be read + ! in a new file which means after = 1 (the file to be opened corresponds to the current time) + ! or after = nreclast + 1 (the file to be opened corresponds to a future time step) + IF( .NOT. ll_firstcall .AND. sd(jf)%ln_tint .AND. sd(jf)%nrec_b(1) /= sd(jf)%nreclast & + & .AND. MOD( sd(jf)%nrec_a(1), sd(jf)%nreclast ) == 1 ) THEN + itmp = sd(jf)%nrec_a(1) ! temporary storage + sd(jf)%nrec_a(1) = sd(jf)%nreclast ! read the last record of the file currently opened + CALL fld_get( sd(jf) ) ! read after data + sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field + sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations + sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. ) ! assume freq to be in hours in this case + sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations + sd(jf)%nrec_a(1) = itmp ! move back to after record + ENDIF + + CALL fld_clopn( sd(jf) ) ! Do we need to open a new year/month/week/day file? + + IF( sd(jf)%ln_tint ) THEN + + ! if kn_fsbc*rdt is larger than freqh (which is kind of odd), + ! it is possible that the before value is no more the good one... we have to re-read it + ! if before record is not just just before the after record... + IF( .NOT. ll_firstcall .AND. MOD( sd(jf)%nrec_a(1), sd(jf)%nreclast ) /= 1 & + & .AND. sd(jf)%nrec_b(1) /= sd(jf)%nrec_a(1) - 1 ) THEN + sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - 1 ! move back to before record + CALL fld_get( sd(jf) ) ! read after data + sd(jf)%fdta(:,:,:,1) = sd(jf)%fdta(:,:,:,2) ! re-swap before record field + sd(jf)%nrec_b(1) = sd(jf)%nrec_a(1) ! update before record informations + sd(jf)%nrec_b(2) = sd(jf)%nrec_a(2) - NINT( sd(jf)%freqh * 3600. ) ! assume freq to be in hours in this case + sd(jf)%rotn(1) = sd(jf)%rotn(2) ! update before rotate informations + sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) + 1 ! move back to after record + ENDIF + ENDIF ! temporal interpolation? + + ! do we have to change the year/month/week/day of the forcing field?? + ! if we do time interpolation we will need to open next year/month/week/day file before the end of the current + ! one. If so, we are still before the end of the year/month/week/day when calling fld_rec so sd(jf)%nrec_a(1) + ! will be larger than the record number that should be read for current year/month/week/day + ! do we need next file data? + ! This applies to both cases with or without time interpolation + IF( sd(jf)%nrec_a(1) > sd(jf)%nreclast ) THEN + + sd(jf)%nrec_a(1) = sd(jf)%nrec_a(1) - sd(jf)%nreclast ! + + IF( .NOT. ( sd(jf)%ln_clim .AND. sd(jf)%cltype == 'yearly' ) ) THEN ! close/open the current/new file + + llnxtmth = sd(jf)%cltype == 'monthly' .OR. nday == nmonth_len(nmonth) ! open next month file? + llnxtyr = sd(jf)%cltype == 'yearly' .OR. (nmonth == 12 .AND. llnxtmth) ! open next year file? + + ! if the run finishes at the end of the current year/month/week/day, we will allow next + ! year/month/week/day file to be not present. If the run continue further than the current + ! year/month/week/day, next year/month/week/day file must exist + isecend = nsec_year + nsec1jan000 + (nitend - kt) * NINT(rdt) ! second at the end of the run + llstop = isecend > sd(jf)%nrec_a(2) ! read more than 1 record of next year + ! we suppose that the date of next file is next day (should be ok even for weekly files...) + CALL fld_clopn( sd(jf), nyear + COUNT((/llnxtyr /)) , & + & nmonth + COUNT((/llnxtmth/)) - 12 * COUNT((/llnxtyr /)), & + & nday + 1 - nmonth_len(nmonth) * COUNT((/llnxtmth/)), llstop ) + + IF( sd(jf)%num <= 0 .AND. .NOT. llstop ) THEN ! next year file does not exist + CALL ctl_warn('next year/month/week/day file: '//TRIM(sd(jf)%clname)// & + & ' not present -> back to current year/month/day') + CALL fld_clopn( sd(jf) ) ! back to the current year/month/day + sd(jf)%nrec_a(1) = sd(jf)%nreclast ! force to read the last record in the current year file + ENDIF + + ENDIF + ENDIF ! open need next file? + + ! read after data + CALL fld_get( sd(jf) ) + + ENDIF ! read new data? + 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 + ! + IF( sd(jf)%ln_tint ) THEN ! temporal interpolation + IF(lwp .AND. kt - nit000 <= 100 ) 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_b(1), sd(jf)%nrec_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),wp)/rday + WRITE(numout, *) ' it_offset is : ',it_offset + ENDIF + ! temporal interpolation weights + ztinta = REAL( isecsbc - sd(jf)%nrec_b(2), wp ) / REAL( sd(jf)%nrec_a(2) - sd(jf)%nrec_b(2), wp ) + ztintb = 1. - ztinta + sd(jf)%fnow(:,:,:) = ztintb * sd(jf)%fdta(:,:,:,1) + ztinta * sd(jf)%fdta(:,:,:,2) + ELSE ! nothing to do... + IF(lwp .AND. kt - nit000 <= 100 ) 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_a(1), REAL(sd(jf)%nrec_b(2),wp)/rday, REAL(sd(jf)%nrec_a(2),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( kn_fsbc, sdjf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_init *** + !! + !! ** Purpose : - first call to fld_rec to define before values + !! - if time interpolation, read before data + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + !! + LOGICAL :: llprevyr ! are we reading previous year file? + LOGICAL :: llprevmth ! are we reading previous month file? + LOGICAL :: llprevweek ! are we reading previous week file? + LOGICAL :: llprevday ! are we reading previous day file? + LOGICAL :: llprev ! llprevyr .OR. llprevmth .OR. llprevweek .OR. llprevday + INTEGER :: idvar ! variable id + INTEGER :: inrec ! number of record existing for this variable + INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd + INTEGER :: isec_week ! number of seconds since start of the weekly file + CHARACTER(LEN=1000) :: clfmt ! write format + !!--------------------------------------------------------------------- + ! + llprevyr = .FALSE. + llprevmth = .FALSE. + llprevweek = .FALSE. + llprevday = .FALSE. + isec_week = 0 + ! + ! define record informations + CALL fld_rec( kn_fsbc, sdjf, ldbefore = .TRUE. ) ! return before values in sdjf%nrec_a (as we will swap it later) + ! + ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar + ! + IF( sdjf%ln_tint ) THEN ! we need to read the previous record and we will put it in the current record structure + ! + IF( sdjf%nrec_a(1) == 0 ) THEN ! we redefine record sdjf%nrec_a(1) with the last record of previous year file + IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean + IF( sdjf%cltype == 'yearly' ) THEN ! yearly file + sdjf%nrec_a(1) = 1 ! force to read the unique record + llprevyr = .NOT. sdjf%ln_clim ! use previous year file? + ELSE + CALL ctl_stop( "fld_init: yearly mean file must be in a yearly type of file: "//TRIM(sdjf%clrootname) ) + ENDIF + ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean + IF( sdjf%cltype == 'monthly' ) THEN ! monthly file + sdjf%nrec_a(1) = 1 ! force to read the unique record + llprevmth = .TRUE. ! use previous month file? + llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? + ELSE ! yearly file + sdjf%nrec_a(1) = 12 ! force to read december mean + llprevyr = .NOT. sdjf%ln_clim ! use previous year file? + ENDIF + ELSE ! higher frequency mean (in hours) + IF ( sdjf%cltype == 'monthly' ) THEN ! monthly file + sdjf%nrec_a(1) = NINT( 24. * REAL(nmonth_len(nmonth-1),wp) / sdjf%freqh )! last record of previous month + llprevmth = .TRUE. ! use previous month file? + llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? + ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ! weekly file + llprevweek = .TRUE. ! use previous week file? + sdjf%nrec_a(1) = NINT( 24. * 7. / sdjf%freqh ) ! last record of previous week + isec_week = NINT(rday) * 7 ! add a shift toward previous week + ELSEIF( sdjf%cltype == 'daily' ) THEN ! daily file + sdjf%nrec_a(1) = NINT( 24. / sdjf%freqh ) ! last record of previous day + llprevday = .TRUE. ! use previous day file? + llprevmth = llprevday .AND. nday == 1 ! use previous month file? + llprevyr = llprevmth .AND. nmonth == 1 ! use previous year file? + ELSE ! yearly file + sdjf%nrec_a(1) = NINT( 24. * REAL(nyear_len(0),wp) / sdjf%freqh ) ! last record of previous year + llprevyr = .NOT. sdjf%ln_clim ! use previous year file? + ENDIF + ENDIF + ENDIF + ! + IF ( sdjf%cltype(1:4) == 'week' ) THEN + isec_week = isec_week + ksec_week( sdjf%cltype(6:8) ) ! second since the beginning of the week + llprevmth = isec_week > nsec_month ! longer time since the beginning of the week than the month + llprevyr = llprevmth .AND. nmonth == 1 + ENDIF + llprev = llprevyr .OR. llprevmth .OR. llprevweek .OR. llprevday + ! + iyear = nyear - COUNT((/llprevyr /)) + imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) + iday = nday - COUNT((/llprevday/)) + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) + ! + CALL fld_clopn( sdjf, iyear, imonth, iday, .NOT. llprev ) + ! + ! if previous year/month/day file does not exist, we switch to the current year/month/day + IF( llprev .AND. sdjf%num <= 0 ) THEN + CALL ctl_warn( 'previous year/month/week/day file: '//TRIM(sdjf%clrootname)// & + & ' not present -> back to current year/month/week/day' ) + ! we force to read the first record of the current year/month/day instead of last record of previous year/month/day + llprev = .FALSE. + sdjf%nrec_a(1) = 1 + CALL fld_clopn( sdjf ) + ENDIF + ! + IF( llprev ) THEN ! check if the record sdjf%nrec_a(1) exists in the file + idvar = iom_varid( sdjf%num, sdjf%clvar ) ! id of the variable sdjf%clvar + IF( idvar <= 0 ) RETURN + inrec = iom_file( sdjf%num )%dimsz( iom_file( sdjf%num )%ndims(idvar), idvar ) ! size of the last dim of idvar + sdjf%nrec_a(1) = MIN( sdjf%nrec_a(1), inrec ) ! make sure we select an existing record + ENDIF + ! + ! read before data in after arrays(as we will swap it later) + CALL fld_get( sdjf ) + ! + clfmt = "(' fld_init : time-interpolation for ', a, ' read previous record = ', i6, ' at time = ', f7.2, ' days')" + IF(lwp) WRITE(numout, clfmt) TRIM(sdjf%clvar), sdjf%nrec_a(1), REAL(sdjf%nrec_a(2),wp)/rday + ! + ENDIF + ! + END SUBROUTINE fld_init + + + SUBROUTINE fld_rec( kn_fsbc, sdjf, ldbefore, kit, kt_offset ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_rec *** + !! + !! ** Purpose : Compute + !! if sdjf%ln_tint = .TRUE. + !! nrec_a: record number and its time (nrec_b is obtained from nrec_a when swapping) + !! if sdjf%ln_tint = .FALSE. + !! nrec_a(1): record number + !! nrec_b(2) and nrec_a(2): time of the beginning and end of the record + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kn_fsbc ! sbc computation period (in time step) + TYPE(FLD), INTENT(inout) :: sdjf ! input field related variables + LOGICAL , INTENT(in ), OPTIONAL :: ldbefore ! sent back before record values (default = .FALSE.) + INTEGER , INTENT(in ), OPTIONAL :: kit ! index of barotropic subcycle + ! ! used only if sdjf%ln_tint = .TRUE. + INTEGER , INTENT(in ), OPTIONAL :: kt_offset ! Offset of required time level compared to "now" + ! ! time level in units of time steps. + ! + LOGICAL :: llbefore ! local definition of ldbefore + INTEGER :: iendrec ! end of this record (in seconds) + INTEGER :: imth ! month number + INTEGER :: ifreq_sec ! frequency mean (in seconds) + INTEGER :: isec_week ! number of seconds since the start of the weekly file + INTEGER :: it_offset ! local time offset variable + REAL(wp) :: ztmp ! temporary variable + !!---------------------------------------------------------------------- + ! + ! Note that shifting time to be centrered in the middle of sbc time step impacts only nsec_* variables of the calendar + ! + IF( PRESENT(ldbefore) ) THEN ; llbefore = ldbefore .AND. sdjf%ln_tint ! needed only if sdjf%ln_tint = .TRUE. + ELSE ; llbefore = .FALSE. + ENDIF + ! + IF ( nn_components == jp_iam_sas ) THEN ; it_offset = nn_fsbc + ELSE ; it_offset = 0 + ENDIF + IF( PRESENT(kt_offset) ) it_offset = kt_offset + IF( PRESENT(kit) ) THEN ; it_offset = ( kit + it_offset ) * NINT( rdt/REAL(nn_baro,wp) ) + ELSE ; it_offset = it_offset * NINT( rdt ) + ENDIF + ! + ! ! =========== ! + IF ( NINT(sdjf%freqh) == -12 ) THEN ! yearly mean + ! ! =========== ! + ! + IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record + ! + ! INT( ztmp ) + ! /|\ + ! 1 | *---- + ! 0 |----( + ! |----+----|--> time + ! 0 /|\ 1 (nday/nyear_len(1)) + ! | + ! | + ! forcing record : 1 + ! + ztmp = REAL( nsec_year, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + 0.5 & + & + REAL( it_offset, wp ) / ( REAL( nyear_len(1), wp ) * rday ) + sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) + ! swap at the middle of the year + IF( llbefore ) THEN ; sdjf%nrec_a(2) = nsec1jan000 - (1 - INT(ztmp)) * NINT(0.5 * rday) * nyear_len(0) + & + & INT(ztmp) * NINT( 0.5 * rday) * nyear_len(1) + ELSE ; sdjf%nrec_a(2) = nsec1jan000 + (1 - INT(ztmp)) * NINT(0.5 * rday) * nyear_len(1) + & + & INT(ztmp) * INT(rday) * nyear_len(1) + INT(ztmp) * NINT( 0.5 * rday) * nyear_len(2) + ENDIF + ELSE ! no time interpolation + sdjf%nrec_a(1) = 1 + sdjf%nrec_a(2) = NINT(rday) * nyear_len(1) + nsec1jan000 ! swap at the end of the year + sdjf%nrec_b(2) = nsec1jan000 ! beginning of the year (only for print) + ENDIF + ! + ! ! ============ ! + ELSEIF( NINT(sdjf%freqh) == -1 ) THEN ! monthly mean ! + ! ! ============ ! + ! + IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record + ! + ! INT( ztmp ) + ! /|\ + ! 1 | *---- + ! 0 |----( + ! |----+----|--> time + ! 0 /|\ 1 (nday/nmonth_len(nmonth)) + ! | + ! | + ! forcing record : nmonth + ! + ztmp = REAL( nsec_month, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + 0.5 & + & + REAL( it_offset, wp ) / ( REAL( nmonth_len(nmonth), wp ) * rday ) + imth = nmonth + INT( ztmp ) - COUNT((/llbefore/)) + IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) + ELSE ; sdjf%nrec_a(1) = imth + ENDIF + sdjf%nrec_a(2) = nmonth_half( imth ) + nsec1jan000 ! swap at the middle of the month + ELSE ! no time interpolation + IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nrec_a(1) = 1 + ELSE ; sdjf%nrec_a(1) = nmonth + ENDIF + sdjf%nrec_a(2) = nmonth_end(nmonth ) + nsec1jan000 ! swap at the end of the month + sdjf%nrec_b(2) = nmonth_end(nmonth-1) + nsec1jan000 ! beginning of the month (only for print) + ENDIF + ! + ! ! ================================ ! + ELSE ! higher frequency mean (in hours) + ! ! ================================ ! + ! + ifreq_sec = NINT( sdjf%freqh * 3600. ) ! frequency mean (in seconds) + IF( sdjf%cltype(1:4) == 'week' ) isec_week = ksec_week( sdjf%cltype(6:8) ) ! since the first day of the current week + ! number of second since the beginning of the file + IF( sdjf%cltype == 'monthly' ) THEN ; ztmp = REAL(nsec_month,wp) ! since the first day of the current month + ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; ztmp = REAL(isec_week ,wp) ! since the first day of the current week + ELSEIF( sdjf%cltype == 'daily' ) THEN ; ztmp = REAL(nsec_day ,wp) ! since 00h of the current day + ELSE ; ztmp = REAL(nsec_year ,wp) ! since 00h on Jan 1 of the current year + ENDIF + ztmp = ztmp + 0.5 * REAL(kn_fsbc - 1, wp) * rdt + REAL( it_offset, wp ) ! centrered in the middle of sbc time step + ztmp = ztmp + 0.01 * rdt ! avoid truncation error + IF( sdjf%ln_tint ) THEN ! time interpolation, shift by 1/2 record + ! + ! INT( ztmp/ifreq_sec + 0.5 ) + ! /|\ + ! 2 | *-----( + ! 1 | *-----( + ! 0 |--( + ! |--+--|--+--|--+--|--> time + ! 0 /|\ 1 /|\ 2 /|\ 3 (ztmp/ifreq_sec) + ! | | | + ! | | | + ! forcing record : 1 2 3 + ! + ztmp= ztmp / REAL(ifreq_sec, wp) + 0.5 + ELSE ! no time interpolation + ! + ! INT( ztmp/ifreq_sec ) + ! /|\ + ! 2 | *-----( + ! 1 | *-----( + ! 0 |-----( + ! |--+--|--+--|--+--|--> time + ! 0 /|\ 1 /|\ 2 /|\ 3 (ztmp/ifreq_sec) + ! | | | + ! | | | + ! forcing record : 1 2 3 + ! + ztmp= ztmp / REAL(ifreq_sec, wp) + ENDIF + sdjf%nrec_a(1) = 1 + INT( ztmp ) - COUNT((/llbefore/)) ! record number to be read + + iendrec = ifreq_sec * sdjf%nrec_a(1) + nsec1jan000 ! end of this record (in second) + ! add the number of seconds between 00h Jan 1 and the end of previous month/week/day (ok if nmonth=1) + IF( sdjf%cltype == 'monthly' ) iendrec = iendrec + NINT(rday) * SUM(nmonth_len(1:nmonth -1)) + IF( sdjf%cltype(1:4) == 'week' ) iendrec = iendrec + ( nsec_year - isec_week ) + IF( sdjf%cltype == 'daily' ) iendrec = iendrec + NINT(rday) * ( nday_year - 1 ) + IF( sdjf%ln_tint ) THEN + sdjf%nrec_a(2) = iendrec - ifreq_sec / 2 ! swap at the middle of the record + ELSE + sdjf%nrec_a(2) = iendrec ! swap at the end of the record + sdjf%nrec_b(2) = iendrec - ifreq_sec ! beginning of the record (only for print) + ENDIF + ! + ENDIF + ! + IF( .NOT. sdjf%ln_tint ) sdjf%nrec_a(2) = sdjf%nrec_a(2) - 1 ! last second belongs to bext record : *----( + ! + END SUBROUTINE fld_rec + + + SUBROUTINE fld_get( sdjf ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_get *** + !! + !! ** Purpose : read the data + !!---------------------------------------------------------------------- + TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables + ! + INTEGER :: ipk ! number of vertical levels of sdjf%fdta ( 2D: ipk=1 ; 3D: ipk=jpk ) + INTEGER :: iw ! index into wgts array + INTEGER :: ipdom ! index of the domain + INTEGER :: idvar ! variable ID + INTEGER :: idmspc ! number of spatial dimensions + LOGICAL :: lmoor ! C1D case: point data + !!--------------------------------------------------------------------- + ! + ipk = SIZE( sdjf%fnow, 3 ) + ! + IF( ASSOCIATED(sdjf%imap) ) THEN + IF( sdjf%ln_tint ) THEN ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1), & + & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) + ELSE ; CALL fld_map( sdjf%num, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1), & + & sdjf%imap, sdjf%igrd, sdjf%ibdy, sdjf%ltotvel, sdjf%lzint ) + ENDIF + ELSE IF( LEN(TRIM(sdjf%wgtname)) > 0 ) THEN + CALL wgt_list( sdjf, iw ) + IF( sdjf%ln_tint ) THEN ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fdta(:,:,:,2), & + & sdjf%nrec_a(1), sdjf%lsmname ) + ELSE ; CALL fld_interp( sdjf%num, sdjf%clvar, iw, ipk, sdjf%fnow(:,:,: ), & + & sdjf%nrec_a(1), sdjf%lsmname ) + ENDIF + ELSE + IF( SIZE(sdjf%fnow, 1) == jpi ) THEN ; ipdom = jpdom_data + ELSE ; ipdom = jpdom_unknown + ENDIF + ! C1D case: If product of spatial dimensions == ipk, then x,y are of + ! size 1 (point/mooring data): this must be read onto the central grid point + idvar = iom_varid( sdjf%num, sdjf%clvar ) + idmspc = iom_file ( sdjf%num )%ndims( idvar ) + IF( iom_file( sdjf%num )%luld( idvar ) ) idmspc = idmspc - 1 + lmoor = ( idmspc == 0 .OR. PRODUCT( iom_file( sdjf%num )%dimsz( 1:MAX(idmspc,1) ,idvar ) ) == ipk ) + ! + SELECT CASE( ipk ) + CASE(1) + IF( lk_c1d .AND. lmoor ) THEN + IF( sdjf%ln_tint ) THEN + CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fdta(2,2,1,2), sdjf%nrec_a(1) ) + CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,1,2),'Z',1. ) + ELSE + CALL iom_get( sdjf%num, sdjf%clvar, sdjf%fnow(2,2,1 ), sdjf%nrec_a(1) ) + CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,1 ),'Z',1. ) + ENDIF + ELSE + IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,1,2), sdjf%nrec_a(1) ) + ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,1 ), sdjf%nrec_a(1) ) + ENDIF + ENDIF + CASE DEFAULT + IF (lk_c1d .AND. lmoor ) THEN + IF( sdjf%ln_tint ) THEN + CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fdta(2,2,:,2), sdjf%nrec_a(1) ) + CALL lbc_lnk( 'fldread', sdjf%fdta(:,:,:,2),'Z',1. ) + ELSE + CALL iom_get( sdjf%num, jpdom_unknown, sdjf%clvar, sdjf%fnow(2,2,: ), sdjf%nrec_a(1) ) + CALL lbc_lnk( 'fldread', sdjf%fnow(:,:,: ),'Z',1. ) + ENDIF + ELSE + IF( sdjf%ln_tint ) THEN ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fdta(:,:,:,2), sdjf%nrec_a(1) ) + ELSE ; CALL iom_get( sdjf%num, ipdom, sdjf%clvar, sdjf%fnow(:,:,: ), sdjf%nrec_a(1) ) + ENDIF + ENDIF + END SELECT + ENDIF + ! + sdjf%rotn(2) = .false. ! vector not yet rotated + ! + END SUBROUTINE fld_get + + + SUBROUTINE fld_map( knum, cdvar, pdta, krec, kmap, kgrd, kbdy, ldtotvel, ldzint ) + !!--------------------------------------------------------------------- + !! *** 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 :: 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) :: clgrid + LOGICAL :: lluld ! is the variable using the unlimited dimension + LOGICAL :: llzint ! local value of ldzint + !!--------------------------------------------------------------------- + ! + clgrid = (/'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'//clgrid(kgrd)) /= -1 .AND. iom_varid(knum,'e3'//clgrid(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'//clgrid(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'//clgrid(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) + 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'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1//'gdep'//clgrid(kgrd)//' variable' ) + IF( iom_varid(knum, 'e3'//clgrid(kgrd)) == -1 ) CALL ctl_stop( ctmp1// 'e3'//clgrid(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) + !!--------------------------------------------------------------------- + !! *** 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 :: 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_n(ji,jj,:) + 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_n(ji,jj,1) + 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_n(ji,jj,jk-1) + zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3uw_n(ji,jj,jk)) & + & + (1.-zcoef) * ( zdepth(jk-1) + e3uw_n(ji,jj,jk)) + 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_n(ji,jj,1) + 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_n(ji,jj,jk-1) + zdepth(jk) = zcoef * ( zdhalf(jk ) + 0.5 * e3vw_n(ji,jj,jk)) & + & + (1.-zcoef) * ( zdepth(jk-1) + e3vw_n(ji,jj,jk)) + 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 + ! + 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_n(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_n(ji,jj) ) * 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_n(ji,jj) ) * 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_n(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_n(ji,jj) ) * 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_n(ji,jj) ) * 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 + !!--------------------------------------------------------------------- + ! + !! (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 + DO jk = 1, SIZE( sd(ju)%fnow, 3 ) + IF( sd(ju)%ln_tint )THEN + CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->i', utmp(:,:) ) + CALL rot_rep( sd(ju)%fdta(:,:,jk,jn), sd(iv)%fdta(:,:,jk,jn), 'T', 'en->j', vtmp(:,:) ) + sd(ju)%fdta(:,:,jk,jn) = utmp(:,:) ; sd(iv)%fdta(:,:,jk,jn) = vtmp(:,:) + ELSE + CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->i', utmp(:,:) ) + CALL rot_rep( sd(ju)%fnow(:,:,jk ), sd(iv)%fnow(:,:,jk ), 'T', 'en->j', vtmp(:,:) ) + sd(ju)%fnow(:,:,jk ) = utmp(:,:) ; sd(iv)%fnow(:,:,jk ) = vtmp(:,:) + ENDIF + 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_clopn( sdjf, kyear, kmonth, kday, ldstop ) + !!--------------------------------------------------------------------- + !! *** ROUTINE fld_clopn *** + !! + !! ** Purpose : update the file name and close/open the files + !!---------------------------------------------------------------------- + TYPE(FLD) , INTENT(inout) :: sdjf ! input field related variables + INTEGER, OPTIONAL, INTENT(in ) :: kyear ! year value + INTEGER, OPTIONAL, INTENT(in ) :: kmonth ! month value + INTEGER, OPTIONAL, INTENT(in ) :: kday ! day value + LOGICAL, OPTIONAL, INTENT(in ) :: ldstop ! stop if open to read a non-existing file (default = .TRUE.) + ! + LOGICAL :: llprevyr ! are we reading previous year file? + LOGICAL :: llprevmth ! are we reading previous month file? + INTEGER :: iyear, imonth, iday ! first day of the current file in yyyy mm dd + INTEGER :: isec_week ! number of seconds since start of the weekly file + INTEGER :: indexyr ! year undex (O/1/2: previous/current/next) + REAL(wp) :: zyear_len, zmonth_len ! length (days) of iyear and imonth ! + CHARACTER(len = 256) :: clname ! temporary file name + !!---------------------------------------------------------------------- + IF( PRESENT(kyear) ) THEN ! use given values + iyear = kyear + imonth = kmonth + iday = kday + IF ( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of the week + isec_week = ksec_week( sdjf%cltype(6:8) )- (86400 * 8 ) + llprevmth = isec_week > nsec_month ! longer time since beginning of the week than the month + llprevyr = llprevmth .AND. nmonth == 1 + iyear = nyear - COUNT((/llprevyr /)) + imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) + iday = nday + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) + ENDIF + ELSE ! use current day values + IF ( sdjf%cltype(1:4) == 'week' ) THEN ! find the day of the beginning of the week + isec_week = ksec_week( sdjf%cltype(6:8) ) ! second since the beginning of the week + llprevmth = isec_week > nsec_month ! longer time since beginning of the week than the month + llprevyr = llprevmth .AND. nmonth == 1 + ELSE + isec_week = 0 + llprevmth = .FALSE. + llprevyr = .FALSE. + ENDIF + iyear = nyear - COUNT((/llprevyr /)) + imonth = nmonth - COUNT((/llprevmth/)) + 12 * COUNT((/llprevyr /)) + iday = nday + nmonth_len(nmonth-1) * COUNT((/llprevmth/)) - isec_week / NINT(rday) + ENDIF + + ! 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 ), iyear ! add year + IF( sdjf%cltype /= 'yearly' ) WRITE(clname, '(a,"m" ,i2.2)' ) TRIM( clname ), imonth ! add month + ELSE + ! build the new filename if climatological data + IF( sdjf%cltype /= 'yearly' ) WRITE(clname, '(a,"_m",i2.2)' ) TRIM( sdjf%clrootname ), imonth ! add month + ENDIF + IF( sdjf%cltype == 'daily' .OR. sdjf%cltype(1:4) == 'week' ) & + & WRITE(clname, '(a,"d" ,i2.2)' ) TRIM( clname ), iday ! add day + ! + IF( TRIM(clname) /= TRIM(sdjf%clname) .OR. sdjf%num == 0 ) THEN ! new file to be open + ! + sdjf%clname = TRIM(clname) + IF( sdjf%num /= 0 ) CALL iom_close( sdjf%num ) ! close file if already open + CALL iom_open( sdjf%clname, sdjf%num, ldstop = ldstop, ldiof = LEN(TRIM(sdjf%wgtname)) > 0 ) + ! + ! find the last record to be read -> update sdjf%nreclast + indexyr = iyear - nyear + 1 + zyear_len = REAL(nyear_len( indexyr ), wp) + SELECT CASE ( indexyr ) + CASE ( 0 ) ; zmonth_len = 31. ! previous year -> imonth = 12 + CASE ( 1 ) ; zmonth_len = REAL(nmonth_len(imonth), wp) + CASE ( 2 ) ; zmonth_len = 31. ! next year -> imonth = 1 + END SELECT + ! + ! last record to be read in the current file + IF ( sdjf%freqh == -12. ) THEN ; sdjf%nreclast = 1 ! yearly mean + ELSEIF( sdjf%freqh == -1. ) THEN ! monthly mean + IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = 1 + ELSE ; sdjf%nreclast = 12 + ENDIF + ELSE ! higher frequency mean (in hours) + IF( sdjf%cltype == 'monthly' ) THEN ; sdjf%nreclast = NINT( 24. * zmonth_len / sdjf%freqh ) + ELSEIF( sdjf%cltype(1:4) == 'week' ) THEN ; sdjf%nreclast = NINT( 24. * 7. / sdjf%freqh ) + ELSEIF( sdjf%cltype == 'daily' ) THEN ; sdjf%nreclast = NINT( 24. / sdjf%freqh ) + ELSE ; sdjf%nreclast = NINT( 24. * zyear_len / sdjf%freqh ) + ENDIF + ENDIF + ! + 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)%cltype = sdf_n(jf)%cltype + sdf(jf)%num = -1 + 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)%cltype(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)%cltype(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)%cltype , & + & ' 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(inout) :: kwgt ! index of weights + ! + INTEGER :: kw, nestid ! local integer + LOGICAL :: found ! local logical + !!---------------------------------------------------------------------- + ! + !! search down linked list + !! weights filename is either present or we hit the end of the list + found = .FALSE. + ! + !! 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 +#if defined key_agrif + nestid = Agrif_Fixed() +#endif + DO kw = 1, nxt_wgt-1 + IF( TRIM(ref_wgts(kw)%wgtname) == TRIM(sd%wgtname) .AND. & + ref_wgts(kw)%nestid == nestid) THEN + kwgt = kw + found = .TRUE. + EXIT + ENDIF + END DO + IF( .NOT.found ) THEN + kwgt = nxt_wgt + CALL fld_weight( sd ) + ENDIF + ! + 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 :: 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) :: aname ! + INTEGER , DIMENSION(:), ALLOCATABLE :: ddims + INTEGER, DIMENSION(jpi,jpj) :: data_src + 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 + + !! open input data file (non-model grid) + CALL iom_open( sd%clname, inum, ldiof = LEN(TRIM(sd%wgtname)) > 0 ) + + !! get dimensions + IF ( SIZE(sd%fnow, 3) > 1 ) THEN + ALLOCATE( ddims(4) ) + ELSE + ALLOCATE( ddims(3) ) + ENDIF + id = iom_varid( inum, sd%clvar, ddims ) + + !! close it + CALL iom_close( inum ) + + !! 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 +#if defined key_agrif + ref_wgts(nxt_wgt)%nestid = Agrif_Fixed() +#endif + !! 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(jpi,jpj,4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_jpj(jpi,jpj,4) ) + ALLOCATE( ref_wgts(nxt_wgt)%data_wgt(jpi,jpj,ref_wgts(nxt_wgt)%numwgt) ) + + DO jn = 1,4 + aname = ' ' + WRITE(aname,'(a3,i2.2)') 'src',jn + data_tmp(:,:) = 0 + CALL iom_get ( inum, jpdom_data, aname, data_tmp(:,:) ) + data_src(:,:) = INT(data_tmp(:,:)) + ref_wgts(nxt_wgt)%data_jpj(:,:,jn) = 1 + (data_src(:,:)-1) / ref_wgts(nxt_wgt)%ddims(1) + ref_wgts(nxt_wgt)%data_jpi(:,:,jn) = data_src(:,:) - ref_wgts(nxt_wgt)%ddims(1)*(ref_wgts(nxt_wgt)%data_jpj(:,:,jn)-1) + END DO + + DO jn = 1, ref_wgts(nxt_wgt)%numwgt + aname = ' ' + WRITE(aname,'(a3,i2.2)') 'wgt',jn + ref_wgts(nxt_wgt)%data_wgt(:,:,jn) = 0.0 + CALL iom_get ( inum, jpdom_data, aname, ref_wgts(nxt_wgt)%data_wgt(:,:,jn) ) + 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 + + DEALLOCATE (ddims ) + ! + 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, rec1_lsm, recn_lsm) + CASE DEFAULT + CALL iom_get( inum, jpdom_unknown, 'LSM', zslmec1(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), 1, rec1_lsm, 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, DIMENSION (ileni,ilenj), INTENT(in ) :: zfieldn ! array of forcing field with undeff for land points + REAL, DIMENSION (ileni,ilenj), INTENT( out) :: zfield ! array of forcing field + ! + REAL , DIMENSION (ileni,ilenj) :: zmat1, zmat2, zmat3, zmat4 ! local arrays + REAL , DIMENSION (ileni,ilenj) :: zmat5, zmat6, zmat7, zmat8 ! - - + REAL , DIMENSION (ileni,ilenj) :: zlsm2d ! - - + REAL , 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 :: jk, jn, jm, jir, jjr ! loop counters + 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 + !!---------------------------------------------------------------------- + ! + !! 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, rec1_lsm, recn_lsm) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ztmp_fly_dta(jpi1_lsm:jpi2_lsm,jpj1_lsm:jpj2_lsm,:), & + & nrec, rec1_lsm, 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 + SELECT CASE( SIZE(ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:),3) ) + CASE(1) + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,1), nrec, rec1, recn) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%fly_dta(jpi1:jpi2,jpj1:jpj2,:), nrec, rec1, recn) + END SELECT + 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 + dta(:,:,:) = 0.0 + DO jk = 1,4 + DO jn = 1, jpj + DO jm = 1,jpi + ni = ref_wgts(kw)%data_jpi(jm,jn,jk) + nj = ref_wgts(kw)%data_jpj(jm,jn,jk) + dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk) * ref_wgts(kw)%fly_dta(ni+1,nj+1,:) + 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 + SELECT CASE( SIZE( ref_wgts(kw)%col(:,jpj1:jpj2,:),3) ) + CASE(1) + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,1), nrec, rec1, recn) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn) + END SELECT + 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 + SELECT CASE( SIZE( ref_wgts(kw)%col(:,jpj1:jpj2,:),3) ) + CASE(1) + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,1), nrec, rec1, recn) + CASE DEFAULT + CALL iom_get( num, jpdom_unknown, clvar, ref_wgts(kw)%col(:,jpj1:jpj2,:), nrec, rec1, recn) + END SELECT + ref_wgts(kw)%fly_dta(jpi2+1,jpj1:jpj2,:) = ref_wgts(kw)%col(1,jpj1:jpj2,:) + ENDIF + ENDIF + + ! gradient in the i direction + DO jk = 1,4 + DO jn = 1, jpj + DO jm = 1,jpi + ni = ref_wgts(kw)%data_jpi(jm,jn,jk) + nj = ref_wgts(kw)%data_jpj(jm,jn,jk) + dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+4) * 0.5 * & + (ref_wgts(kw)%fly_dta(ni+2,nj+1,:) - ref_wgts(kw)%fly_dta(ni,nj+1,:)) + END DO + END DO + END DO + + ! gradient in the j direction + DO jk = 1,4 + DO jn = 1, jpj + DO jm = 1,jpi + ni = ref_wgts(kw)%data_jpi(jm,jn,jk) + nj = ref_wgts(kw)%data_jpj(jm,jn,jk) + dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+8) * 0.5 * & + (ref_wgts(kw)%fly_dta(ni+1,nj+2,:) - ref_wgts(kw)%fly_dta(ni+1,nj,:)) + END DO + END DO + END DO + + ! gradient in the ij direction + DO jk = 1,4 + DO jn = 1, jpj + DO jm = 1,jpi + ni = ref_wgts(kw)%data_jpi(jm,jn,jk) + nj = ref_wgts(kw)%data_jpj(jm,jn,jk) + dta(jm,jn,:) = dta(jm,jn,:) + ref_wgts(kw)%data_wgt(jm,jn,jk+12) * 0.25 * ( & + (ref_wgts(kw)%fly_dta(ni+2,nj+2,:) - ref_wgts(kw)%fly_dta(ni ,nj+2,:)) - & + (ref_wgts(kw)%fly_dta(ni+2,nj ,:) - ref_wgts(kw)%fly_dta(ni ,nj ,:))) + END DO + END DO + END DO + ! + END IF + ! + END SUBROUTINE fld_interp + + + FUNCTION ksec_week( cdday ) + !!--------------------------------------------------------------------- + !! *** FUNCTION kshift_week *** + !! + !! ** Purpose : return the first 3 letters of the first day of the weekly file + !!--------------------------------------------------------------------- + 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%cltype(6:8): '//TRIM(cdday) ) + ! + ishift = ijul * NINT(rday) + ! + ksec_week = nsec_week + ishift + ksec_week = MOD( ksec_week, 7*NINT(rday) ) + ! + END FUNCTION ksec_week + + !!====================================================================== +END MODULE fldread diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/geo2ocean.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/geo2ocean.F90 new file mode 100644 index 0000000..46977cc --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/geo2ocean.F90 @@ -0,0 +1,467 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 = 2, jpjm1 + DO ji = fs_2, jpi ! vector opt. + ! + 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 = 2, jpjm1 + DO ji = fs_2, jpi ! vector opt. + 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_multi( 'geo2ocean', gcost, 'T', -1., gsint, 'T', -1., gcosu, 'U', -1., gsinu, 'U', -1., & + & gcosv, 'V', -1., gsinv, 'V', -1., gcosf, 'F', -1., gsinf, 'F', -1. ) + ! + 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/NEMO_4.0.4_surge/src/OCE/SBC/ocealb.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/ocealb.F90 new file mode 100644 index 0000000..d22be96 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/ocealb.F90 @@ -0,0 +1,48 @@ +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$ + !! 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/NEMO_4.0.4_surge/src/OCE/SBC/sbc_ice.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbc_ice.F90 new file mode 100644 index 0000000..d1f69d2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbc_ice.F90 @@ -0,0 +1,205 @@ +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 + !!---------------------------------------------------------------------- +#if defined key_si3 || defined key_cice + !!---------------------------------------------------------------------- + !! 'key_si3' or 'key_cice' : SI3 or CICE sea-ice model + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE sbc_oce ! surface boundary condition: ocean +# if defined key_si3 + USE ice ! SI3 parameters +# endif +# if defined key_cice + USE ice_domain_size, only: ncat +#endif + USE lib_mpp ! MPP library + USE in_out_manager ! I/O manager + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_ice_alloc ! called in sbcmod.F90 or sbcice_cice.F90 + +# if defined key_si3 + LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .TRUE. !: SI3 ice model + LOGICAL , PUBLIC, PARAMETER :: lk_cice = .FALSE. !: no CICE +# endif +# if defined key_cice + LOGICAL , PUBLIC, PARAMETER :: lk_si3 = .FALSE. !: no SI3 + LOGICAL , PUBLIC, PARAMETER :: lk_cice = .TRUE. !: CICE ice model +# endif + + 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(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] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qtr_ice_top !: solar flux transmitted below the ice surface [W/m2] + + 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(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_ice !: sublimation - precip over sea ice [kg/m2/s] + + 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] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: devap_ice !: sublimation sensitivity [kg/m2/s/K] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qns_oce !: non solar heat flux over ocean [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qsr_oce !: non solar heat flux over ocean [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_oce !: heat flux of precip and evap over ocean [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qemp_ice !: heat flux of precip and evap over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qevap_ice !: heat flux of evap over ice [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qprec_ice !: enthalpy of precip over ice [J/m3] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: emp_oce !: evap - precip over ocean [kg/m2/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndm_ice !: wind speed module at T-point [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sstfrz !: sea surface freezing temperature [degC] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rCdU_ice !: ice-ocean drag at T-point (<0) [m/s] +#endif + +#if defined key_cice + ! + ! for consistency with SI3, these are declared with three dimensions + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: qlw_ice !: incoming long-wave + ! + ! other forcing arrays are two dimensional + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iou !: x ice-ocean surface stress at NEMO U point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ss_iov !: y ice-ocean surface stress at NEMO V point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qatm_ice !: specific humidity + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndi_ice !: i wind at T point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: wndj_ice !: j wind at T point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nfrzmlt !: NEMO frzmlt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iu !: ice fraction at NEMO U point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: fr_iv !: ice fraction at NEMO V point + + ! variables used in the coupled interface + INTEGER , PUBLIC, PARAMETER :: jpl = ncat + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: u_ice, v_ice + + ! already defined in ice.F90 for SI3 + 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 + + REAL(wp), PUBLIC, SAVE :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] + + !! arrays relating to embedding ice in the ocean + 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) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_ice_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ice_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(4) + !!---------------------------------------------------------------------- + ierr(:) = 0 + + ALLOCATE( snwice_mass(jpi,jpj) , snwice_mass_b(jpi,jpj), snwice_fmass(jpi,jpj) , STAT=ierr(1) ) + +#if defined key_si3 + ALLOCATE( qns_ice (jpi,jpj,jpl) , qsr_ice (jpi,jpj,jpl) , & + & qla_ice (jpi,jpj,jpl) , dqla_ice (jpi,jpj,jpl) , & + & dqns_ice(jpi,jpj,jpl) , tn_ice (jpi,jpj,jpl) , alb_ice (jpi,jpj,jpl) , & + & qml_ice (jpi,jpj,jpl) , qcn_ice (jpi,jpj,jpl) , qtr_ice_top(jpi,jpj,jpl) , & + & utau_ice(jpi,jpj) , vtau_ice (jpi,jpj) , wndm_ice (jpi,jpj) , & + & evap_ice(jpi,jpj,jpl) , devap_ice(jpi,jpj,jpl) , qprec_ice (jpi,jpj) , & + & qemp_ice(jpi,jpj) , qevap_ice(jpi,jpj,jpl) , qemp_oce (jpi,jpj) , & + & qns_oce (jpi,jpj) , qsr_oce (jpi,jpj) , emp_oce (jpi,jpj) , & + & emp_ice (jpi,jpj) , sstfrz (jpi,jpj) , rCdU_ice (jpi,jpj) , STAT= ierr(2) ) +#endif + +#if defined key_cice + ALLOCATE( qla_ice(jpi,jpj,1) , qlw_ice(jpi,jpj,1) , qsr_ice(jpi,jpj,1) , & + wndi_ice(jpi,jpj) , tatm_ice(jpi,jpj) , qatm_ice(jpi,jpj) , & + wndj_ice(jpi,jpj) , nfrzmlt(jpi,jpj) , ss_iou(jpi,jpj) , & + ss_iov(jpi,jpj) , fr_iu(jpi,jpj) , fr_iv(jpi,jpj) , & + a_i(jpi,jpj,ncat) , topmelt(jpi,jpj,ncat) , botmelt(jpi,jpj,ncat) , & + STAT= ierr(2) ) + IF( ln_cpl ) ALLOCATE( u_ice(jpi,jpj) , tn_ice (jpi,jpj,1) , & + & v_ice(jpi,jpj) , alb_ice(jpi,jpj,1) , & + & emp_ice(jpi,jpj) , qns_ice(jpi,jpj,1) , dqns_ice(jpi,jpj,1) , & + & STAT= ierr(3) ) + IF( ln_cpl ) ALLOCATE( h_i(jpi,jpj,jpl) , h_s(jpi,jpj,jpl) , STAT=ierr(4) ) +#endif + + 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 + +#else + !!---------------------------------------------------------------------- + !! 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 + REAL(wp) , PUBLIC, PARAMETER :: pp_cldf = 0.81 !: cloud fraction over sea ice, summer CLIO value [-] + 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 +#endif + + !!====================================================================== +END MODULE sbc_ice diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbc_oce.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbc_oce.F90 new file mode 100644 index 0000000..2118a0c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbc_oce.F90 @@ -0,0 +1,227 @@ +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) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 +#if defined key_oasis3 + LOGICAL , PUBLIC :: lk_oasis = .TRUE. !: OASIS used +#else + LOGICAL , PUBLIC :: lk_oasis = .FALSE. !: OASIS unused +#endif + 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_isf !: ice shelf melting + 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_wave !: true if some coupling with wave model + LOGICAL , PUBLIC :: ln_cdgw !: true if neutral drag coefficient from wave model + LOGICAL , PUBLIC :: ln_sdw !: true if 3d stokes drift from wave model + LOGICAL , PUBLIC :: ln_tauwoc !: true if normalized stress from wave is used + LOGICAL , PUBLIC :: ln_tauw !: true if ocean stress components from wave is used + LOGICAL , PUBLIC :: ln_stcor !: true if Stokes-Coriolis term is used + ! + INTEGER , PUBLIC :: nn_sdrift ! type of parameterization to calculate vertical Stokes drift + ! + 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 + + !!---------------------------------------------------------------------- + !! 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_purecpl = 4 !: Pure ocean-atmosphere Coupled formulation + INTEGER , PUBLIC, PARAMETER :: jp_none = 5 !: for OPA when doing coupling via SAS module + + !!---------------------------------------------------------------------- + !! Stokes drift parametrization definition + !!---------------------------------------------------------------------- + INTEGER , PUBLIC, PARAMETER :: jp_breivik_2014 = 0 !: Breivik 2014: v_z=v_0*[exp(2*k*z)/(1-8*k*z)] + INTEGER , PUBLIC, PARAMETER :: jp_li_2017 = 1 !: Li et al 2017: Stokes drift based on Phillips spectrum (Breivik 2016) + ! with depth averaged profile + INTEGER , PUBLIC, PARAMETER :: jp_peakfr = 2 !: Li et al 2017: using the peak wave number read from wave model instead + ! of the inverse depth scale + LOGICAL , PUBLIC :: ll_st_bv2014 = .FALSE. ! logical indicator, .true. if Breivik 2014 parameterisation is active. + LOGICAL , PUBLIC :: ll_st_li2017 = .FALSE. ! logical indicator, .true. if Li 2017 parameterisation is active. + LOGICAL , PUBLIC :: ll_st_bv_li = .FALSE. ! logical indicator, .true. if either Breivik or Li parameterisation is active. + LOGICAL , PUBLIC :: ll_st_peakfr = .FALSE. ! logical indicator, .true. if using Li 2017 with peak wave number + + !!---------------------------------------------------------------------- + !! component definition + !!---------------------------------------------------------------------- + INTEGER , PUBLIC, PARAMETER :: jp_iam_nemo = 0 !: Initial single executable configuration + ! (no internal OASIS coupling) + INTEGER , PUBLIC, PARAMETER :: jp_iam_opa = 1 !: Multi executable configuration - OPA 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) + ! + LOGICAL , PUBLIC :: lhftau = .FALSE. !: HF tau used in TKE: mean(stress module) - module(mean stress) + !! !! 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(:,:) :: taum !: module of sea surface stress (at T-point) [N/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: uwnd !: wind speed i-component [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vwnd !: wind speed j-component [m/s] + !! wndm is used onmpute 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(:,:) :: 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(:,:) :: fwfisf , fwfisf_b !: ice shelf melting [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) [-] + + !!---------------------------------------------------------------------- + !! 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(:,:) :: 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 [-] + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_oce_alloc() + !!--------------------------------------------------------------------- + !! *** FUNCTION sbc_oce_alloc *** + !!--------------------------------------------------------------------- + INTEGER :: ierr(5) + !!--------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( utau(jpi,jpj) , utau_b(jpi,jpj) , taum(jpi,jpj) , & + & vtau(jpi,jpj) , vtau_b(jpi,jpj) , wndm(jpi,jpj) , & + & uwnd(jpi,jpj) , vwnd(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( fwfisf (jpi,jpj), rnf (jpi,jpj) , sbc_tsc (jpi,jpj,jpts) , qsr_hc (jpi,jpj,jpk) , & + & fwfisf_b(jpi,jpj), 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) , 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) ) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vect. opt. + 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. ) + ! + END SUBROUTINE sbc_tau2wnd + + !!====================================================================== +END MODULE sbc_oce diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcapr.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcapr.F90 new file mode 100644 index 0000000..0a4189a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcapr.F90 @@ -0,0 +1,179 @@ +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 * rau0) + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_apr ! structure of input fields (file informations, fields read) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + LOGICAL :: lrxios ! read restart using XIOS? + !! + NAMELIST/namsbc_apr/ cn_dir, sn_apr, ln_ref_apr, rn_pref, ln_apr_obc + !!---------------------------------------------------------------------- + REWIND( numnam_ref ) ! Namelist namsbc_apr in reference namelist : File for atmospheric pressure forcing + READ ( numnam_ref, namsbc_apr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_apr in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_apr in configuration namelist : File for atmospheric pressure forcing + 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 * rau0) !* 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' ) + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('ssh_ibb') + ENDIF + 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. iom_varid( numror, 'ssh_ibb', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) 'sbc_apr: ssh_ibb read in the restart file' + CALL iom_get( numror, jpdom_autoglo, 'ssh_ibb', ssh_ibb, ldxios = lrxios ) ! 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,*) '~~~~' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_ibb' , ssh_ib, ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + END SUBROUTINE sbc_apr + + !!====================================================================== +END MODULE sbcapr diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk.F90 new file mode 100644 index 0000000..365b7e0 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk.F90 @@ -0,0 +1,1249 @@ +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 (http://aerobulk.sourceforge.net/) + !! 4.0 ! 2016-10 (G. Madec) introduce a sbc_blk_init routine + !! 4.0 ! 2016-10 (M. Vancoppenolle) Introduce conduction flux emulator (M. Vancoppenolle) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 : computes momentum, heat and freshwater fluxes over ocean + !! rho_air : density of (moist) air (depends on T_air, q_air and SLP + !! cp_air : specific heat of (moist) air (depends spec. hum. q_air) + !! q_sat : saturation humidity as a function of SLP and temperature + !! L_vap : latent heat of vaporization of water as a function of temperature + !! sea-ice case only : + !! blk_ice_tau : provide the air-ice stress + !! blk_ice_flx : 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) + !! Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag + !! Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag + !!---------------------------------------------------------------------- + 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 cyclone ! Cyclone 10m wind form trac of cyclone centres + USE sbcdcy ! surface boundary condition: diurnal cycle + USE sbcwave , ONLY : cdn_wave ! wave module + USE sbc_ice ! Surface boundary condition: ice fields + USE lib_fortran ! to use key_nosignedzero +#if defined key_si3 + USE ice , ONLY : u_ice, v_ice, jpl, a_i_b, at_i_b, t_su, rn_cnd_s, hfx_err_dif, nn_qtrice + USE icevar ! for CALL ice_var_snwblow +#endif + USE sbcblk_algo_ncar ! => turb_ncar : NCAR - CORE (Large & Yeager, 2009) + USE sbcblk_algo_coare ! => turb_coare : COAREv3.0 (Fairall et al. 2003) + USE sbcblk_algo_coare3p5 ! => turb_coare3p5 : COAREv3.5 (Edson et al. 2013) + USE sbcblk_algo_ecmwf ! => turb_ecmwf : ECMWF (IFS cycle 31) + ! + 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 + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_blk_init ! called in sbcmod + PUBLIC sbc_blk ! called in sbcmod +#if defined key_si3 + PUBLIC blk_ice_tau ! routine called in icesbc + PUBLIC blk_ice_flx ! routine called in icesbc + PUBLIC blk_ice_qcn ! routine called in icesbc +#endif + +!!Lolo: should ultimately be moved in the module with all physical constants ? +!!gm : In principle, yes. + REAL(wp), PARAMETER :: Cp_dry = 1005.0 !: Specic heat of dry air, constant pressure [J/K/kg] + REAL(wp), PARAMETER :: Cp_vap = 1860.0 !: Specic heat of water vapor, constant pressure [J/K/kg] + REAL(wp), PARAMETER :: R_dry = 287.05_wp !: Specific gas constant for dry air [J/K/kg] + REAL(wp), PARAMETER :: R_vap = 461.495_wp !: Specific gas constant for water vapor [J/K/kg] + REAL(wp), PARAMETER :: reps0 = R_dry/R_vap !: ratio of gas constant for dry air and water vapor => ~ 0.622 + REAL(wp), PARAMETER :: rctv0 = R_vap/R_dry - 1._wp !: for virtual temperature (== (1-eps)/eps) => ~ 0.608 + + INTEGER , PARAMETER :: jpfld =11 ! maximum number of files to read + INTEGER , PARAMETER :: jp_wndi = 1 ! index of 10m wind velocity (i-component) (m/s) at T-point + INTEGER , PARAMETER :: jp_wndj = 2 ! index of 10m wind velocity (j-component) (m/s) at T-point + INTEGER , PARAMETER :: jp_tair = 3 ! index of 10m air temperature (Kelvin) + INTEGER , PARAMETER :: jp_humi = 4 ! index of specific humidity ( % ) + INTEGER , PARAMETER :: jp_qsr = 5 ! index of solar heat (W/m2) + INTEGER , PARAMETER :: jp_qlw = 6 ! index of Long wave (W/m2) + INTEGER , PARAMETER :: jp_prec = 7 ! index of total precipitation (rain+snow) (Kg/m2/s) + INTEGER , PARAMETER :: jp_snow = 8 ! index of snow (solid prcipitation) (kg/m2/s) + INTEGER , PARAMETER :: jp_slp = 9 ! index of sea level pressure (Pa) + INTEGER , PARAMETER :: jp_cc =10 ! index of cloud cover (-) range:0-1 + INTEGER , PARAMETER :: jp_tdif =11 ! index of tau diff associated to HF tau (N/m2) at T-point + + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + ! !!! Bulk parameters + REAL(wp), PARAMETER :: cpa = 1000.5 ! specific heat of air (only used for ice fluxes now...) + REAL(wp), PARAMETER :: Ls = 2.839e6 ! latent heat of sublimation + REAL(wp), PARAMETER :: Stef = 5.67e-8 ! Stefan Boltzmann constant + REAL(wp), PARAMETER :: Cd_ice = 1.4e-3 ! transfer coefficient over ice + REAL(wp), PARAMETER :: albo = 0.066 ! ocean albedo assumed to be constant + ! + ! !!* 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_3p5 ! "COARE 3.5" algorithm (Edson et al. 2013) + LOGICAL :: ln_ECMWF ! "ECMWF" algorithm (IFS cycle 31) + ! + LOGICAL :: ln_taudif ! logical flag to use the "mean of stress module - module of mean stress" data + REAL(wp) :: rn_pfac ! multiplication factor for precipitation + REAL(wp) :: rn_efac ! multiplication factor for evaporation + REAL(wp) :: rn_vfac ! multiplication factor for ice/ocean velocity in the calculation of wind stress + REAL(wp) :: rn_zqt ! z(q,t) : height of humidity and temperature measurements + REAL(wp) :: rn_zu ! z(u) : height of wind measurements +!!gm ref namelist initialize it so remove the setting to false below + LOGICAL :: ln_Cd_L12 = .FALSE. ! Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2012) + LOGICAL :: ln_Cd_L15 = .FALSE. ! Modify the drag ice-atm depending on ice concentration (from Lupkes et al. JGR2015) + ! + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Cd_atm ! transfer coefficient for momentum (tau) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ch_atm ! transfer coefficient for sensible heat (Q_sens) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: Ce_atm ! tansfert coefficient for evaporation (Q_lat) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: t_zu ! air temperature at wind speed height (needed by Lupkes 2015 bulk scheme) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: q_zu ! air spec. hum. at wind speed height (needed by Lupkes 2015 bulk scheme) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: cdn_oce, chn_oce, cen_oce ! needed by Lupkes 2015 bulk scheme + + 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_3p5 = 3 ! "COARE 3.5" algorithm (Edson et al. 2013) + INTEGER, PARAMETER :: np_ECMWF = 4 ! "ECMWF" algorithm (IFS cycle 31) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_blk_alloc() + !!------------------------------------------------------------------- + !! *** ROUTINE sbc_blk_alloc *** + !!------------------------------------------------------------------- + ALLOCATE( Cd_atm (jpi,jpj), Ch_atm (jpi,jpj), Ce_atm (jpi,jpj), t_zu(jpi,jpj), q_zu(jpi,jpj), & + & cdn_oce(jpi,jpj), chn_oce(jpi,jpj), cen_oce(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, jfld ! 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_tdif, sn_cc ! " " + NAMELIST/namsbc_blk/ sn_wndi, sn_wndj, sn_humi, sn_qsr, sn_qlw , & ! input fields + & sn_tair, sn_prec, sn_snow, sn_slp, sn_tdif, sn_cc, & + & ln_NCAR, ln_COARE_3p0, ln_COARE_3p5, ln_ECMWF, & ! bulk algorithm + & cn_dir , ln_taudif, rn_zqt, rn_zu, & + & rn_pfac, rn_efac, rn_vfac, ln_Cd_L12, ln_Cd_L15 + !!--------------------------------------------------------------------- + ! + ! ! allocate sbc_blk_core array + IF( sbc_blk_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_blk : unable to allocate standard arrays' ) + ! + ! !** read bulk namelist + REWIND( numnam_ref ) !* Namelist namsbc_blk in reference namelist : bulk parameters + READ ( numnam_ref, namsbc_blk, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_blk in reference namelist' ) + ! + REWIND( numnam_cfg ) !* Namelist namsbc_blk in configuration namelist : bulk parameters + 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_3p5 ) THEN ; nblk = np_COARE_3p5 ; ioptio = ioptio + 1 ; ENDIF + IF( ln_ECMWF ) THEN ; nblk = np_ECMWF ; ioptio = ioptio + 1 ; ENDIF + ! + IF( ioptio /= 1 ) CALL ctl_stop( 'sbc_blk_init: Choose one and only one bulk algorithm' ) + ! + 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_tdif) = sn_tdif + ! + lhftau = ln_taudif !- add an extra field if HF stress is used + jfld = jpfld - COUNT( (/.NOT.lhftau/) ) + ! + ! !- allocate the bulk structure + ALLOCATE( sf(jfld), 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' ) + ! + DO jfpr = 1, jfld + ! + IF( TRIM(sf(jfpr)%clrootname) == 'NOT USED' ) THEN !-- not used field --! (only now allocated and set to zero) + ALLOCATE( sf(jfpr)%fnow(jpi,jpj,1) ) + sf(jfpr)%fnow(:,:,1) = 0._wp + ELSE !-- used field --! + ALLOCATE( sf(jfpr)%fnow(jpi,jpj,1) ) + IF( slf_i(jfpr)%ln_tint ) ALLOCATE( sf(jfpr)%fdta(jpi,jpj,1,2) ) + IF( slf_i(jfpr)%freqh > 0. .AND. MOD( NINT(3600. * slf_i(jfpr)%freqh), nn_fsbc * NINT(rdt) ) /= 0 ) & + & CALL ctl_warn( 'sbc_blk_init: sbcmod timestep rdt*nn_fsbc is NOT a submultiple of atmospheric forcing frequency.', & + & ' This is not ideal. You should consider changing either rdt or nn_fsbc value...' ) + ENDIF + ENDDO + ! fill cloud cover array with constant value if "not used" + IF( TRIM(sf(jp_cc)%clrootname) == 'NOT USED' ) sf(jp_cc)%fnow(:,:,1) = pp_cldf + + IF ( ln_wave ) THEN + !Activated wave module but neither drag nor stokes drift activated + IF ( .NOT.(ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) ) THEN + CALL ctl_stop( 'STOP', 'Ask for wave coupling but ln_cdgw=F, ln_sdw=F, ln_tauwoc=F, ln_stcor=F' ) + !drag coefficient read from wave model definable only with mfs bulk formulae and core + ELSEIF (ln_cdgw .AND. .NOT. ln_NCAR ) THEN + CALL ctl_stop( 'drag coefficient read from wave model definable only with NCAR and CORE bulk formulae') + ELSEIF (ln_stcor .AND. .NOT. ln_sdw) THEN + CALL ctl_stop( 'Stokes-Coriolis term calculated only if activated Stokes Drift ln_sdw=T') + ENDIF + ELSE + IF ( ln_cdgw .OR. ln_sdw .OR. ln_tauwoc .OR. ln_stcor ) & + & CALL ctl_stop( 'Not Activated Wave Module (ln_wave=F) but asked coupling ', & + & 'with drag coefficient (ln_cdgw =T) ' , & + & 'or Stokes Drift (ln_sdw=T) ' , & + & 'or ocean stress modification due to waves (ln_tauwoc=T) ', & + & 'or Stokes-Coriolis term (ln_stcori=T)' ) + 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.5" algorithm (Edson et al. 2013) ln_COARE_3p5 = ', ln_COARE_3p5 + WRITE(numout,*) ' "ECMWF" algorithm (IFS cycle 31) ln_ECMWF = ', ln_ECMWF + WRITE(numout,*) ' add High freq.contribution to the stress module ln_taudif = ', ln_taudif + 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,*) ' factor applied on ocean/ice velocity rn_vfac = ', rn_vfac + WRITE(numout,*) ' (form absolute (=0) to relative winds(=1))' + WRITE(numout,*) ' use ice-atm drag from Lupkes2012 ln_Cd_L12 = ', ln_Cd_L12 + WRITE(numout,*) ' use ice-atm drag from Lupkes2015 ln_Cd_L15 = ', ln_Cd_L15 + ! + 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_3p5 ) ; WRITE(numout,*) ' ==>>> "COARE 3.5" algorithm (Edson et al. 2013)' + CASE( np_ECMWF ) ; WRITE(numout,*) ' ==>>> "ECMWF" algorithm (IFS cycle 31)' + END SELECT + ! + 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 10m wind velocity (i-component) (m/s) at T-point + !! the 10m wind velocity (j-component) (m/s) at T-point + !! the 10m or 2m specific humidity ( % ) + !! the solar heat (W/m2) + !! the Long wave (W/m2) + !! the 10m or 2m air temperature (Kelvin) + !! the total precipitation (rain+snow) (Kg/m2/s) + !! the snow (solid prcipitation) (kg/m2/s) + !! the tau diff associated to HF tau (N/m2) at T-point (ln_taudif=T) + !! (2) CALL blk_oce + !! + !! 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 + !!--------------------------------------------------------------------- + ! + CALL fld_read( kt, nn_fsbc, sf ) ! input fields provided at the current time-step + ! + ! ! compute the surface ocean fluxes using bulk formulea + IF( MOD( kt - 1, nn_fsbc ) == 0 ) CALL blk_oce( kt, sf, sst_m, ssu_m, ssv_m ) + +#if defined key_cice + IF( MOD( kt - 1, nn_fsbc ) == 0 ) THEN + qlw_ice(:,:,1) = sf(jp_qlw )%fnow(:,:,1) + IF( ln_dm2dc ) THEN ; qsr_ice(:,:,1) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) + ELSE ; qsr_ice(:,:,1) = sf(jp_qsr)%fnow(:,:,1) + ENDIF + tatm_ice(:,:) = sf(jp_tair)%fnow(:,:,1) + qatm_ice(:,:) = sf(jp_humi)%fnow(:,:,1) + tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac + sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac + wndi_ice(:,:) = sf(jp_wndi)%fnow(:,:,1) + wndj_ice(:,:) = sf(jp_wndj)%fnow(:,:,1) + ENDIF +#endif + ! + END SUBROUTINE sbc_blk + + + SUBROUTINE blk_oce( kt, sf, pst, pu, pv ) + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_oce *** + !! + !! ** Purpose : provide the momentum, heat and freshwater fluxes at + !! the ocean surface at each time step + !! + !! ** Method : bulk formulea for the ocean using atmospheric + !! fields read in sbc_read + !! + !! ** 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) + !! + !! ** Nota : sf has to be a dummy argument for AGRIF on NEC + !!--------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step index + TYPE(fld), INTENT(inout), DIMENSION(:) :: sf ! input data + REAL(wp) , INTENT(in) , DIMENSION(:,:) :: pst ! surface temperature [Celcius] + 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] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zztmp ! local variable + REAL(wp), DIMENSION(jpi,jpj) :: zwnd_i, zwnd_j ! wind speed components at T-point + REAL(wp), DIMENSION(jpi,jpj) :: zsq ! specific humidity at pst + REAL(wp), DIMENSION(jpi,jpj) :: zqlw, zqsb ! long wave and sensible heat fluxes + REAL(wp), DIMENSION(jpi,jpj) :: zqla, zevap ! latent heat fluxes and evaporation + REAL(wp), DIMENSION(jpi,jpj) :: zst ! surface temperature in Kelvin + REAL(wp), DIMENSION(jpi,jpj) :: zU_zu ! bulk wind speed at height zu [m/s] + REAL(wp), DIMENSION(jpi,jpj) :: ztpot ! potential temperature of air at z=rn_zqt [K] + REAL(wp), DIMENSION(jpi,jpj) :: zrhoa ! density of air [kg/m^3] + !!--------------------------------------------------------------------- + ! + ! local scalars ( place there for vector optimisation purposes) + zst(:,:) = pst(:,:) + rt0 ! convert SST from Celcius to Kelvin (and set minimum value far above 0 K) + + ! --- 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) +!!gm move zwnd_i (_j) set to zero inside the key_cyclone ??? + zwnd_i(:,:) = 0._wp + zwnd_j(:,:) = 0._wp +#if defined key_cyclone + CALL wnd_cyc( kt, zwnd_i, zwnd_j ) ! add analytical tropical cyclone (Vincent et al. JGR 2012) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vect. opt. + sf(jp_wndi)%fnow(ji,jj,1) = sf(jp_wndi)%fnow(ji,jj,1) + zwnd_i(ji,jj) + sf(jp_wndj)%fnow(ji,jj,1) = sf(jp_wndj)%fnow(ji,jj,1) + zwnd_j(ji,jj) + END DO + END DO +#endif + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vect. opt. + zwnd_i(ji,jj) = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pu(ji-1,jj ) + pu(ji,jj) ) ) + zwnd_j(ji,jj) = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( pv(ji ,jj-1) + pv(ji,jj) ) ) + END DO + END DO + CALL lbc_lnk_multi( 'sbcblk', zwnd_i, 'T', -1., zwnd_j, 'T', -1. ) + ! ... scalar wind ( = | U10m - U_oce | ) at T-point (masked) + wndm(:,:) = SQRT( zwnd_i(:,:) * zwnd_i(:,:) & + & + zwnd_j(:,:) * zwnd_j(:,:) ) * tmask(:,:,1) + + ! ----------------------------------------------------------------------------- ! + ! I Radiative FLUXES ! + ! ----------------------------------------------------------------------------- ! + + ! 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( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) + ELSE ; qsr(:,:) = zztmp * sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + zqlw(:,:) = ( sf(jp_qlw)%fnow(:,:,1) - Stef * zst(:,:)*zst(:,:)*zst(:,:)*zst(:,:) ) * tmask(:,:,1) ! Long Wave + + ! ----------------------------------------------------------------------------- ! + ! II Turbulent FLUXES ! + ! ----------------------------------------------------------------------------- ! + + ! ... specific humidity at SST and IST tmask( + zsq(:,:) = 0.98 * q_sat( zst(:,:), sf(jp_slp)%fnow(:,:,1) ) + !! + !! Estimate of potential temperature at z=rn_zqt, based on adiabatic lapse-rate + !! (see Josey, Gulev & Yu, 2013) / doi=10.1016/B978-0-12-391851-2.00005-2 + !! (since reanalysis products provide T at z, not theta !) + ztpot = sf(jp_tair)%fnow(:,:,1) + gamma_moist( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1) ) * rn_zqt + + SELECT CASE( nblk ) !== transfer coefficients ==! Cd, Ch, Ce at T-point + ! + CASE( np_NCAR ) ; CALL turb_ncar ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! NCAR-COREv2 + & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) + CASE( np_COARE_3p0 ) ; CALL turb_coare ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! COARE v3.0 + & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) + CASE( np_COARE_3p5 ) ; CALL turb_coare3p5( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! COARE v3.5 + & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) + CASE( np_ECMWF ) ; CALL turb_ecmwf ( rn_zqt, rn_zu, zst, ztpot, zsq, sf(jp_humi)%fnow, wndm, & ! ECMWF + & Cd_atm, Ch_atm, Ce_atm, t_zu, q_zu, zU_zu, cdn_oce, chn_oce, cen_oce ) + CASE DEFAULT + CALL ctl_stop( 'STOP', 'sbc_oce: non-existing bulk formula selected' ) + END SELECT + + ! ! Compute true air density : + IF( ABS(rn_zu - rn_zqt) > 0.01 ) THEN ! At zu: (probably useless to remove zrho*grav*rn_zu from SLP...) + zrhoa(:,:) = rho_air( t_zu(:,:) , q_zu(:,:) , sf(jp_slp)%fnow(:,:,1) ) + ELSE ! At zt: + zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) ) + END IF + +!! CALL iom_put( "Cd_oce", Cd_atm) ! output value of pure ocean-atm. transfer coef. +!! CALL iom_put( "Ch_oce", Ch_atm) ! output value of pure ocean-atm. transfer coef. + + DO jj = 1, jpj ! tau module, i and j component + DO ji = 1, jpi + zztmp = zrhoa(ji,jj) * zU_zu(ji,jj) * Cd_atm(ji,jj) ! using bulk wind speed + taum (ji,jj) = zztmp * wndm (ji,jj) + zwnd_i(ji,jj) = zztmp * zwnd_i(ji,jj) + zwnd_j(ji,jj) = zztmp * zwnd_j(ji,jj) + END DO + END DO + + ! ! add the HF tau contribution to the wind stress module + IF( lhftau ) taum(:,:) = taum(:,:) + sf(jp_tdif)%fnow(:,:,1) + + CALL iom_put( "taum_oce", taum ) ! output wind stress module + + ! ... 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 the use of MAX(tmask(i,j),tmask(i+1,j) is to mask tau over ice shelves + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + utau(ji,jj) = 0.5 * ( 2. - umask(ji,jj,1) ) * ( zwnd_i(ji,jj) + zwnd_i(ji+1,jj ) ) & + & * MAX(tmask(ji,jj,1),tmask(ji+1,jj,1)) + vtau(ji,jj) = 0.5 * ( 2. - vmask(ji,jj,1) ) * ( zwnd_j(ji,jj) + zwnd_j(ji ,jj+1) ) & + & * MAX(tmask(ji,jj,1),tmask(ji,jj+1,1)) + END DO + END DO + CALL lbc_lnk_multi( 'sbcblk', utau, 'U', -1., vtau, 'V', -1. ) + + ! Turbulent fluxes over ocean + ! ----------------------------- + + ! zqla used as temporary array, for rho*U (common term of bulk formulae): + zqla(:,:) = zrhoa(:,:) * zU_zu(:,:) * tmask(:,:,1) + + IF( ABS( rn_zu - rn_zqt) < 0.01_wp ) THEN + !! q_air and t_air are given at 10m (wind reference height) + zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - sf(jp_humi)%fnow(:,:,1)) ) ! Evaporation, using bulk wind speed + zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - ztpot(:,:) ) ! Sensible Heat, using bulk wind speed + ELSE + !! q_air and t_air are not given at 10m (wind reference height) + ! Values of temp. and hum. adjusted to height of wind during bulk algorithm iteration must be used!!! + zevap(:,:) = rn_efac*MAX( 0._wp, zqla(:,:)*Ce_atm(:,:)*(zsq(:,:) - q_zu(:,:) ) ) ! Evaporation, using bulk wind speed + zqsb (:,:) = cp_air(sf(jp_humi)%fnow(:,:,1))*zqla(:,:)*Ch_atm(:,:)*(zst(:,:) - t_zu(:,:) ) ! Sensible Heat, using bulk wind speed + ENDIF + + zqla(:,:) = L_vap(zst(:,:)) * zevap(:,:) ! Latent Heat flux + + + IF(ln_ctl) THEN + CALL prt_ctl( tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=Ce_atm , clinfo2=' Ce_oce : ' ) + CALL prt_ctl( tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=Ch_atm , clinfo2=' Ch_oce : ' ) + CALL prt_ctl( tab2d_1=zqlw , clinfo1=' blk_oce: zqlw : ', tab2d_2=qsr, clinfo2=' qsr : ' ) + CALL prt_ctl( tab2d_1=zsq , clinfo1=' blk_oce: zsq : ', tab2d_2=zst, clinfo2=' zst : ' ) + CALL prt_ctl( tab2d_1=utau , clinfo1=' blk_oce: utau : ', mask1=umask, & + & tab2d_2=vtau , clinfo2= ' vtau : ', mask2=vmask ) + CALL prt_ctl( tab2d_1=wndm , clinfo1=' blk_oce: wndm : ') + CALL prt_ctl( tab2d_1=zst , clinfo1=' blk_oce: zst : ') + ENDIF + + ! ----------------------------------------------------------------------------- ! + ! III Total FLUXES ! + ! ----------------------------------------------------------------------------- ! + ! + emp (:,:) = ( zevap(:,:) & ! mass flux (evap. - precip.) + & - sf(jp_prec)%fnow(:,:,1) * rn_pfac ) * tmask(:,:,1) + ! + qns(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) & ! Downward Non Solar + & - sf(jp_snow)%fnow(:,:,1) * rn_pfac * rLfus & ! remove latent melting heat for solid precip + & - zevap(:,:) * pst(:,:) * rcp & ! remove evap heat content at SST + & + ( sf(jp_prec)%fnow(:,:,1) - sf(jp_snow)%fnow(:,:,1) ) * rn_pfac & ! add liquid precip heat content at Tair + & * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & + & + sf(jp_snow)%fnow(:,:,1) * rn_pfac & ! add solid precip heat content at min(Tair,Tsnow) + & * ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi + qns(:,:) = qns(:,:) * tmask(:,:,1) + ! +#if defined key_si3 + qns_oce(:,:) = zqlw(:,:) - zqsb(:,:) - zqla(:,:) ! non solar without emp (only needed by SI3) + qsr_oce(:,:) = qsr(:,:) +#endif + ! + IF ( nn_ice == 0 ) THEN + CALL iom_put( "qlw_oce" , zqlw ) ! output downward longwave heat over the ocean + CALL iom_put( "qsb_oce" , - zqsb ) ! output downward sensible heat over the ocean + CALL iom_put( "qla_oce" , - zqla ) ! output downward latent heat over the ocean + CALL iom_put( "qemp_oce", qns-zqlw+zqsb+zqla ) ! 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 + tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! output total precipitation [kg/m2/s] + sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! output solid precipitation [kg/m2/s] + CALL iom_put( 'snowpre', sprecip ) ! Snow + CALL iom_put( 'precip' , tprecip ) ! Total precipitation + ENDIF + ! + IF(ln_ctl) THEN + CALL prt_ctl(tab2d_1=zqsb , clinfo1=' blk_oce: zqsb : ', tab2d_2=zqlw , clinfo2=' zqlw : ') + CALL prt_ctl(tab2d_1=zqla , clinfo1=' blk_oce: zqla : ', tab2d_2=qsr , clinfo2=' qsr : ') + CALL prt_ctl(tab2d_1=pst , clinfo1=' blk_oce: pst : ', tab2d_2=emp , clinfo2=' emp : ') + CALL prt_ctl(tab2d_1=utau , clinfo1=' blk_oce: utau : ', mask1=umask, & + & tab2d_2=vtau , clinfo2= ' vtau : ' , mask2=vmask ) + ENDIF + ! + END SUBROUTINE blk_oce + + + + FUNCTION rho_air( ptak, pqa, pslp ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION rho_air *** + !! + !! ** Purpose : compute density of (moist) air using the eq. of state of the atmosphere + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/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) :: pslp ! pressure in [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: rho_air ! density of moist air [kg/m^3] + !!------------------------------------------------------------------------------- + ! + rho_air = pslp / ( R_dry*ptak * ( 1._wp + rctv0*pqa ) ) + ! + END FUNCTION rho_air + + + FUNCTION cp_air( pqa ) + !!------------------------------------------------------------------------------- + !! *** FUNCTION cp_air *** + !! + !! ** Purpose : Compute specific heat (Cp) of moist air + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !!------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! air specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj) :: cp_air ! specific heat of moist air [J/K/kg] + !!------------------------------------------------------------------------------- + ! + Cp_air = Cp_dry + Cp_vap * pqa + ! + END FUNCTION cp_air + + + FUNCTION q_sat( ptak, pslp ) + !!---------------------------------------------------------------------------------- + !! *** FUNCTION q_sat *** + !! + !! ** Purpose : Specific humidity at saturation in [kg/kg] + !! Based on accurate estimate of "e_sat" + !! aka saturation water vapor (Goff, 1957) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pslp ! sea level atmospheric pressure [Pa] + REAL(wp), DIMENSION(jpi,jpj) :: q_sat ! Specific humidity at saturation [kg/kg] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ze_sat, ztmp ! local scalar + !!---------------------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + ztmp = rt0 / ptak(ji,jj) + ! + ! Vapour pressure at saturation [hPa] : WMO, (Goff, 1957) + ze_sat = 10.**( 10.79574*(1. - ztmp) - 5.028*LOG10(ptak(ji,jj)/rt0) & + & + 1.50475*10.**(-4)*(1. - 10.**(-8.2969*(ptak(ji,jj)/rt0 - 1.)) ) & + & + 0.42873*10.**(-3)*(10.**(4.76955*(1. - ztmp)) - 1.) + 0.78614 ) + ! + q_sat(ji,jj) = reps0 * ze_sat/( 0.01_wp*pslp(ji,jj) - (1._wp - reps0)*ze_sat ) ! 0.01 because SLP is in [Pa] + ! + END DO + END DO + ! + END FUNCTION q_sat + + + FUNCTION gamma_moist( ptak, pqa ) + !!---------------------------------------------------------------------------------- + !! *** FUNCTION gamma_moist *** + !! + !! ** 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://sourceforge.net/p/aerobulk) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqa ! specific humidity [kg/kg] + REAL(wp), DIMENSION(jpi,jpj) :: gamma_moist ! moist adiabatic lapse-rate + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zrv, ziRT ! local scalar + !!---------------------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + zrv = pqa(ji,jj) / (1. - pqa(ji,jj)) + ziRT = 1. / (R_dry*ptak(ji,jj)) ! 1/RT + gamma_moist(ji,jj) = grav * ( 1. + rLevap*zrv*ziRT ) / ( Cp_dry + rLevap*rLevap*zrv*reps0*ziRT/ptak(ji,jj) ) + END DO + END DO + ! + END FUNCTION gamma_moist + + + FUNCTION L_vap( psst ) + !!--------------------------------------------------------------------------------- + !! *** FUNCTION L_vap *** + !! + !! ** Purpose : Compute the latent heat of vaporization of water from temperature + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: L_vap ! latent heat of vaporization [J/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: psst ! water temperature [K] + !!---------------------------------------------------------------------------------- + ! + L_vap = ( 2.501 - 0.00237 * ( psst(:,:) - rt0) ) * 1.e6 + ! + END FUNCTION L_vap + +#if defined key_si3 + !!---------------------------------------------------------------------- + !! 'key_si3' SI3 sea-ice model + !!---------------------------------------------------------------------- + !! blk_ice_tau : provide the air-ice stress + !! blk_ice_flx : 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) + !! Cdn10_Lupkes2012 : Lupkes et al. (2012) air-ice drag + !! Cdn10_Lupkes2015 : Lupkes et al. (2015) air-ice drag + !!---------------------------------------------------------------------- + + SUBROUTINE blk_ice_tau + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_ice_tau *** + !! + !! ** Purpose : provide the surface boundary condition over sea-ice + !! + !! ** Method : compute momentum using bulk formulation + !! formulea, ice variables and read atmospheric fields. + !! NB: ice drag coefficient is assumed to be a constant + !!--------------------------------------------------------------------- + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zwndi_f , zwndj_f, zwnorm_f ! relative wind module and components at F-point + REAL(wp) :: zwndi_t , zwndj_t ! relative wind components at T-point + REAL(wp) :: zztmp1 , zztmp2 ! temporary values + REAL(wp), DIMENSION(jpi,jpj) :: zrhoa ! transfer coefficient for momentum (tau) + !!--------------------------------------------------------------------- + ! + ! set transfer coefficients to default sea-ice values + Cd_atm(:,:) = Cd_ice + Ch_atm(:,:) = Cd_ice + Ce_atm(:,:) = Cd_ice + + wndm_ice(:,:) = 0._wp !!gm brutal.... + + ! ------------------------------------------------------------ ! + ! Wind module relative to the moving ice ( U10m - U_ice ) ! + ! ------------------------------------------------------------ ! + ! C-grid ice dynamics : U & V-points (same as ocean) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vect. opt. + zwndi_t = ( sf(jp_wndi)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) + zwndj_t = ( sf(jp_wndj)%fnow(ji,jj,1) - rn_vfac * 0.5 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) + wndm_ice(ji,jj) = SQRT( zwndi_t * zwndi_t + zwndj_t * zwndj_t ) * tmask(ji,jj,1) + END DO + END DO + CALL lbc_lnk( 'sbcblk', wndm_ice, 'T', 1. ) + ! + ! Make ice-atm. drag dependent on ice concentration + IF ( ln_Cd_L12 ) THEN ! calculate new drag from Lupkes(2012) equations + CALL Cdn10_Lupkes2012( Cd_atm ) + Ch_atm(:,:) = Cd_atm(:,:) ! momentum and heat transfer coef. are considered identical + ELSEIF( ln_Cd_L15 ) THEN ! calculate new drag from Lupkes(2015) equations + CALL Cdn10_Lupkes2015( Cd_atm, Ch_atm ) + ENDIF + +!! CALL iom_put( "Cd_ice", Cd_atm) ! output value of pure ice-atm. transfer coef. +!! CALL iom_put( "Ch_ice", Ch_atm) ! output value of pure ice-atm. transfer coef. + + ! local scalars ( place there for vector optimisation purposes) + ! Computing density of air! Way denser that 1.2 over sea-ice !!! + zrhoa (:,:) = rho_air(sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1)) + + ! ------------------------------------------------------------ ! + ! Wind stress relative to the moving ice ( U10m - U_ice ) ! + ! ------------------------------------------------------------ ! + zztmp1 = rn_vfac * 0.5_wp + DO jj = 2, jpj ! at T point + DO ji = 2, jpi + zztmp2 = zrhoa(ji,jj) * Cd_atm(ji,jj) * wndm_ice(ji,jj) + utau_ice(ji,jj) = zztmp2 * ( sf(jp_wndi)%fnow(ji,jj,1) - zztmp1 * ( u_ice(ji-1,jj ) + u_ice(ji,jj) ) ) + vtau_ice(ji,jj) = zztmp2 * ( sf(jp_wndj)%fnow(ji,jj,1) - zztmp1 * ( v_ice(ji ,jj-1) + v_ice(ji,jj) ) ) + END DO + END DO + ! + DO jj = 2, jpjm1 ! U & V-points (same as ocean). + DO ji = fs_2, fs_jpim1 ! vect. opt. + ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology + zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) + zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) + utau_ice(ji,jj) = zztmp1 * ( utau_ice(ji,jj) + utau_ice(ji+1,jj ) ) + vtau_ice(ji,jj) = zztmp2 * ( vtau_ice(ji,jj) + vtau_ice(ji ,jj+1) ) + END DO + END DO + CALL lbc_lnk_multi( 'sbcblk', utau_ice, 'U', -1., vtau_ice, 'V', -1. ) + ! + ! + IF(ln_ctl) THEN + CALL prt_ctl(tab2d_1=utau_ice , clinfo1=' blk_ice: utau_ice : ', tab2d_2=vtau_ice , clinfo2=' vtau_ice : ') + CALL prt_ctl(tab2d_1=wndm_ice , clinfo1=' blk_ice: wndm_ice : ') + ENDIF + ! + END SUBROUTINE blk_ice_tau + + + SUBROUTINE blk_ice_flx( ptsu, phs, phi, palb ) + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_ice_flx *** + !! + !! ** Purpose : provide the heat and mass fluxes at air-ice interface + !! + !! ** Method : compute heat and freshwater exchanged + !! between atmosphere and sea-ice using bulk formulation + !! formulea, ice variables and read atmmospheric fields. + !! + !! caution : the net upward water flux has with mm/day unit + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: ptsu ! sea ice surface temperature + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: phi ! ice thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in) :: palb ! ice albedo (all skies) + !! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp) :: zst3 ! local variable + REAL(wp) :: zcoef_dqlw, zcoef_dqla ! - - + REAL(wp) :: zztmp, z1_rLsub ! - - + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z1_st ! inverse of surface temperature + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qlw ! long wave heat flux over ice + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_qsb ! sensible heat flux over ice + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqlw ! long wave heat sensitivity over ice + REAL(wp), DIMENSION(jpi,jpj,jpl) :: z_dqsb ! sensible heat sensitivity over ice + REAL(wp), DIMENSION(jpi,jpj) :: zevap, zsnw ! evaporation and snw distribution after wind blowing (SI3) + REAL(wp), DIMENSION(jpi,jpj) :: zrhoa + REAL(wp), DIMENSION(jpi,jpj) :: ztmp, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: ztri + !!--------------------------------------------------------------------- + ! + zcoef_dqlw = 4.0 * 0.95 * Stef ! local scalars + zcoef_dqla = -Ls * 11637800. * (-5897.8) + ! + zrhoa(:,:) = rho_air( sf(jp_tair)%fnow(:,:,1), sf(jp_humi)%fnow(:,:,1), sf(jp_slp)%fnow(:,:,1) ) + ! + zztmp = 1. / ( 1. - albo ) + WHERE( ptsu(:,:,:) /= 0._wp ) ; z1_st(:,:,:) = 1._wp / ptsu(:,:,:) + ELSEWHERE ; z1_st(:,:,:) = 0._wp + END WHERE + ! ! ========================== ! + DO jl = 1, jpl ! Loop over ice categories ! + ! ! ========================== ! + DO jj = 1 , jpj + DO ji = 1, jpi + ! ----------------------------! + ! I Radiative FLUXES ! + ! ----------------------------! + zst3 = ptsu(ji,jj,jl) * ptsu(ji,jj,jl) * ptsu(ji,jj,jl) + ! Short Wave (sw) + qsr_ice(ji,jj,jl) = zztmp * ( 1. - palb(ji,jj,jl) ) * qsr(ji,jj) + ! Long Wave (lw) + z_qlw(ji,jj,jl) = 0.95 * ( sf(jp_qlw)%fnow(ji,jj,1) - Stef * ptsu(ji,jj,jl) * zst3 ) * tmask(ji,jj,1) + ! lw sensitivity + z_dqlw(ji,jj,jl) = zcoef_dqlw * zst3 + + ! ----------------------------! + ! II Turbulent FLUXES ! + ! ----------------------------! + + ! ... turbulent heat fluxes with Ch_atm recalculated in blk_ice_tau + ! Sensible Heat + z_qsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) * (ptsu(ji,jj,jl) - sf(jp_tair)%fnow(ji,jj,1)) + ! Latent Heat + qla_ice(ji,jj,jl) = rn_efac * MAX( 0.e0, zrhoa(ji,jj) * Ls * Ch_atm(ji,jj) * wndm_ice(ji,jj) * & + & ( 11637800. * EXP( -5897.8 * z1_st(ji,jj,jl) ) / zrhoa(ji,jj) - sf(jp_humi)%fnow(ji,jj,1) ) ) + ! Latent heat sensitivity for ice (Dqla/Dt) + IF( qla_ice(ji,jj,jl) > 0._wp ) THEN + dqla_ice(ji,jj,jl) = rn_efac * zcoef_dqla * Ch_atm(ji,jj) * wndm_ice(ji,jj) * & + & z1_st(ji,jj,jl)*z1_st(ji,jj,jl) * EXP(-5897.8 * z1_st(ji,jj,jl)) + ELSE + dqla_ice(ji,jj,jl) = 0._wp + ENDIF + + ! Sensible heat sensitivity (Dqsb_ice/Dtn_ice) + z_dqsb(ji,jj,jl) = zrhoa(ji,jj) * cpa * Ch_atm(ji,jj) * wndm_ice(ji,jj) + + ! ----------------------------! + ! III Total FLUXES ! + ! ----------------------------! + ! Downward Non Solar flux + qns_ice (ji,jj,jl) = z_qlw (ji,jj,jl) - z_qsb (ji,jj,jl) - qla_ice (ji,jj,jl) + ! Total non solar heat flux sensitivity for ice + dqns_ice(ji,jj,jl) = - ( z_dqlw(ji,jj,jl) + z_dqsb(ji,jj,jl) + dqla_ice(ji,jj,jl) ) + END DO + ! + END DO + ! + END DO + ! + tprecip(:,:) = sf(jp_prec)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! total precipitation [kg/m2/s] + sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) * rn_pfac * tmask(:,:,1) ! solid precipitation [kg/m2/s] + CALL iom_put( 'snowpre', sprecip ) ! Snow precipitation + CALL iom_put( 'precip' , tprecip ) ! Total precipitation + + ! --- evaporation --- ! + z1_rLsub = 1._wp / rLsub + evap_ice (:,:,:) = rn_efac * qla_ice (:,:,:) * z1_rLsub ! sublimation + devap_ice(:,:,:) = rn_efac * dqla_ice(:,:,:) * z1_rLsub ! d(sublimation)/dT + zevap (:,:) = rn_efac * ( emp(:,:) + tprecip(:,:) ) ! evaporation over ocean + + ! --- evaporation minus precipitation --- ! + zsnw(:,:) = 0._wp + CALL ice_var_snwblow( (1.-at_i_b(:,:)), zsnw ) ! snow distribution over ice after wind blowing + emp_oce(:,:) = ( 1._wp - at_i_b(:,:) ) * zevap(:,:) - ( tprecip(:,:) - sprecip(:,:) ) - sprecip(:,:) * (1._wp - zsnw ) + emp_ice(:,:) = SUM( a_i_b(:,:,:) * evap_ice(:,:,:), dim=3 ) - sprecip(:,:) * zsnw + emp_tot(:,:) = emp_oce(:,:) + emp_ice(:,:) + + ! --- heat flux associated with emp --- ! + qemp_oce(:,:) = - ( 1._wp - at_i_b(:,:) ) * zevap(:,:) * sst_m(:,:) * rcp & ! evap at sst + & + ( tprecip(:,:) - sprecip(:,:) ) * ( sf(jp_tair)%fnow(:,:,1) - rt0 ) * rcp & ! liquid precip at Tair + & + sprecip(:,:) * ( 1._wp - zsnw ) * & ! solid precip at min(Tair,Tsnow) + & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - rLfus ) + qemp_ice(:,:) = sprecip(:,:) * zsnw * & ! solid precip (only) + & ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - rLfus ) + + ! --- total solar and non solar fluxes --- ! + qns_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qns_oce(:,:) + SUM( a_i_b(:,:,:) * qns_ice(:,:,:), dim=3 ) & + & + qemp_ice(:,:) + qemp_oce(:,:) + qsr_tot(:,:) = ( 1._wp - at_i_b(:,:) ) * qsr_oce(:,:) + SUM( a_i_b(:,:,:) * qsr_ice(:,:,:), dim=3 ) + + ! --- heat content of precip over ice in J/m3 (to be used in 1D-thermo) --- ! + qprec_ice(:,:) = rhos * ( ( MIN( sf(jp_tair)%fnow(:,:,1), rt0 ) - rt0 ) * rcpi * tmask(:,:,1) - rLfus ) + + ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- + DO jl = 1, jpl + qevap_ice(:,:,jl) = 0._wp ! should be -evap_ice(:,:,jl)*( ( Tice - rt0 ) * rcpi * tmask(:,:,1) ) + ! ! But we do not have Tice => consider it at 0degC => evap=0 + END DO + + ! --- shortwave radiation transmitted thru the surface scattering layer (W/m2) --- ! + IF( nn_qtrice == 0 ) THEN + ! formulation derived from Grenfell and Maykut (1977), where transmission rate + ! 1) depends on cloudiness + ! 2) is 0 when there is any snow + ! 3) tends to 1 for thin ice + ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm + DO jl = 1, jpl + WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm + qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) + ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm + qtr_ice_top(:,:,jl) = qsr_ice(:,:,jl) * ztri(:,:) + ELSEWHERE ! zero when hs>0 + qtr_ice_top(:,:,jl) = 0._wp + END WHERE + ENDDO + ELSEIF( nn_qtrice == 1 ) THEN + ! formulation is derived from the thesis of M. Lebrun (2019). + ! It represents the best fit using several sets of observations + ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) + qtr_ice_top(:,:,:) = 0.3_wp * qsr_ice(:,:,:) + ENDIF + ! + + IF( iom_use('evap_ao_cea') .OR. iom_use('hflx_evap_cea') ) THEN + ztmp(:,:) = zevap(:,:) * ( 1._wp - at_i_b(:,:) ) + CALL iom_put( 'evap_ao_cea' , ztmp(:,:) * tmask(:,:,1) ) ! ice-free oce evap (cell average) + CALL iom_put( 'hflx_evap_cea', ztmp(:,:) * sst_m(:,:) * rcp * tmask(:,:,1) ) ! heat flux from evap (cell average) + ENDIF + IF( iom_use('hflx_rain_cea') ) THEN + ztmp(:,:) = rcp * ( SUM( (ptsu-rt0) * a_i_b, dim=3 ) + sst_m(:,:) * ( 1._wp - at_i_b(:,:) ) ) + CALL iom_put( 'hflx_rain_cea', ( tprecip(:,:) - sprecip(:,:) ) * ztmp(:,:) ) ! heat flux from rain (cell average) + ENDIF + IF( iom_use('hflx_snow_cea') .OR. iom_use('hflx_snow_ao_cea') .OR. iom_use('hflx_snow_ai_cea') ) THEN + WHERE( SUM( a_i_b, dim=3 ) > 1.e-10 ) ; ztmp(:,:) = rcpi * SUM( (ptsu-rt0) * a_i_b, dim=3 ) / SUM( a_i_b, dim=3 ) + ELSEWHERE ; ztmp(:,:) = rcp * sst_m(:,:) + ENDWHERE + ztmp2(:,:) = sprecip(:,:) * ( ztmp(:,:) - rLfus ) + CALL iom_put('hflx_snow_cea' , ztmp2(:,:) ) ! heat flux from snow (cell average) + CALL iom_put('hflx_snow_ao_cea', ztmp2(:,:) * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) + CALL iom_put('hflx_snow_ai_cea', ztmp2(:,:) * zsnw(:,:) ) ! heat flux from snow (over ice) + ENDIF + ! + IF(ln_ctl) 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 + ! + END SUBROUTINE blk_ice_flx + + + SUBROUTINE blk_ice_qcn( ld_virtual_itd, ptsu, ptb, phs, phi ) + !!--------------------------------------------------------------------- + !! *** ROUTINE blk_ice_qcn *** + !! + !! ** Purpose : Compute surface temperature and snow/ice conduction flux + !! to force sea ice / snow thermodynamics + !! in the case conduction flux is emulated + !! + !! ** Method : compute surface energy balance assuming neglecting heat storage + !! following the 0-layer Semtner (1976) approach + !! + !! ** Outputs : - ptsu : sea-ice / snow surface temperature (K) + !! - qcn_ice : surface inner conduction flux (W/m2) + !! + !!--------------------------------------------------------------------- + LOGICAL , INTENT(in ) :: ld_virtual_itd ! single-category option + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: ptsu ! sea ice / snow surface temperature + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: ptb ! sea ice base temperature + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phs ! snow thickness + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: phi ! sea ice thickness + ! + INTEGER , PARAMETER :: nit = 10 ! number of iterations + REAL(wp), PARAMETER :: zepsilon = 0.1_wp ! characteristic thickness for enhanced conduction + ! + INTEGER :: ji, jj, jl ! dummy loop indices + INTEGER :: iter ! local integer + REAL(wp) :: zfac, zfac2, zfac3 ! local scalars + REAL(wp) :: zkeff_h, ztsu, ztsu0 ! + REAL(wp) :: zqc, zqnet ! + REAL(wp) :: zhe, zqa0 ! + REAL(wp), DIMENSION(jpi,jpj,jpl) :: zgfac ! enhanced conduction factor + !!--------------------------------------------------------------------- + + ! -------------------------------------! + ! I Enhanced conduction factor ! + ! -------------------------------------! + ! Emulates the enhancement of conduction by unresolved thin ice (ld_virtual_itd = T) + ! Fichefet and Morales Maqueda, JGR 1997 + ! + zgfac(:,:,:) = 1._wp + + IF( ld_virtual_itd ) THEN + ! + zfac = 1._wp / ( rn_cnd_s + rcnd_i ) + zfac2 = EXP(1._wp) * 0.5_wp * zepsilon + zfac3 = 2._wp / zepsilon + ! + DO jl = 1, jpl + DO jj = 1 , jpj + DO ji = 1, jpi + zhe = ( rn_cnd_s * phi(ji,jj,jl) + rcnd_i * phs(ji,jj,jl) ) * zfac ! Effective thickness + IF( zhe >= zfac2 ) zgfac(ji,jj,jl) = MIN( 2._wp, 0.5_wp * ( 1._wp + LOG( zhe * zfac3 ) ) ) ! Enhanced conduction factor + END DO + END DO + END DO + ! + ENDIF + + ! -------------------------------------------------------------! + ! II Surface temperature and conduction flux ! + ! -------------------------------------------------------------! + ! + zfac = rcnd_i * rn_cnd_s + ! + DO jl = 1, jpl + DO jj = 1 , jpj + DO ji = 1, jpi + ! + zkeff_h = zfac * zgfac(ji,jj,jl) / & ! Effective conductivity of the snow-ice system divided by thickness + & ( rcnd_i * phs(ji,jj,jl) + rn_cnd_s * MAX( 0.01, phi(ji,jj,jl) ) ) + ztsu = ptsu(ji,jj,jl) ! Store current iteration temperature + ztsu0 = ptsu(ji,jj,jl) ! Store initial surface temperature + zqa0 = qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) ! Net initial atmospheric heat flux + ! + DO iter = 1, nit ! --- Iterative loop + zqc = zkeff_h * ( ztsu - ptb(ji,jj) ) ! Conduction heat flux through snow-ice system (>0 downwards) + zqnet = zqa0 + dqns_ice(ji,jj,jl) * ( ztsu - ptsu(ji,jj,jl) ) - zqc ! Surface energy budget + ztsu = ztsu - zqnet / ( dqns_ice(ji,jj,jl) - zkeff_h ) ! Temperature update + END DO + ! + ptsu (ji,jj,jl) = MIN( rt0, ztsu ) + qcn_ice(ji,jj,jl) = zkeff_h * ( ptsu(ji,jj,jl) - ptb(ji,jj) ) + qns_ice(ji,jj,jl) = qns_ice(ji,jj,jl) + dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) + qml_ice(ji,jj,jl) = ( qsr_ice(ji,jj,jl) - qtr_ice_top(ji,jj,jl) + qns_ice(ji,jj,jl) - qcn_ice(ji,jj,jl) ) & + & * MAX( 0._wp , SIGN( 1._wp, ptsu(ji,jj,jl) - rt0 ) ) + + ! --- Diagnose the heat loss due to changing non-solar flux (as in icethd_zdf_bl99) --- ! + hfx_err_dif(ji,jj) = hfx_err_dif(ji,jj) - ( dqns_ice(ji,jj,jl) * ( ptsu(ji,jj,jl) - ztsu0 ) ) * a_i_b(ji,jj,jl) + + END DO + END DO + ! + END DO + ! + END SUBROUTINE blk_ice_qcn + + + SUBROUTINE Cdn10_Lupkes2012( Cd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Cdn10_Lupkes2012 *** + !! + !! ** Purpose : Recompute the neutral air-ice drag referenced at 10m + !! to make it dependent on edges at leads, melt ponds and flows. + !! 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(:,:), INTENT(inout) :: Cd + REAL(wp), PARAMETER :: zCe = 2.23e-03_wp + REAL(wp), PARAMETER :: znu = 1._wp + REAL(wp), PARAMETER :: zmu = 1._wp + REAL(wp), PARAMETER :: zbeta = 1._wp + REAL(wp) :: zcoef + !!---------------------------------------------------------------------- + zcoef = znu + 1._wp / ( 10._wp * zbeta ) + + ! generic drag over a cell partly covered by ice + !!Cd(:,:) = Cd_oce(:,:) * ( 1._wp - at_i_b(:,:) ) + & ! pure ocean drag + !! & Cd_ice * at_i_b(:,:) + & ! pure ice drag + !! & zCe * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**zmu ! change due to sea-ice morphology + + ! ice-atm drag + Cd(:,:) = Cd_ice + & ! pure ice drag + & zCe * ( 1._wp - at_i_b(:,:) )**zcoef * at_i_b(:,:)**(zmu-1._wp) ! change due to sea-ice morphology + + END SUBROUTINE Cdn10_Lupkes2012 + + + SUBROUTINE Cdn10_Lupkes2015( Cd, Ch ) + !!---------------------------------------------------------------------- + !! *** ROUTINE Cdn10_Lupkes2015 *** + !! + !! ** pUrpose : Alternative turbulent transfert coefficients formulation + !! between sea-ice and atmosphere with distinct momentum + !! and heat coefficients depending on sea-ice concentration + !! and atmospheric stability (no meltponds effect for now). + !! + !! ** Method : The parameterization is adapted from Lupkes et al. (2015) + !! and ECHAM6 atmospheric model. Compared to Lupkes2012 scheme, + !! it considers specific skin and form drags (Andreas et al. 2010) + !! to compute neutral transfert coefficients for both heat and + !! momemtum fluxes. Atmospheric stability effect on transfert + !! coefficient is also taken into account following Louis (1979). + !! + !! ** References : Lupkes et al. JGR 2015 (theory) + !! Lupkes et al. ECHAM6 documentation 2015 (implementation) + !! + !!---------------------------------------------------------------------- + ! + REAL(wp), DIMENSION(:,:), INTENT(inout) :: Cd + REAL(wp), DIMENSION(:,:), INTENT(inout) :: Ch + REAL(wp), DIMENSION(jpi,jpj) :: ztm_su, zst, zqo_sat, zqi_sat + ! + ! ECHAM6 constants + REAL(wp), PARAMETER :: z0_skin_ice = 0.69e-3_wp ! Eq. 43 [m] + REAL(wp), PARAMETER :: z0_form_ice = 0.57e-3_wp ! Eq. 42 [m] + REAL(wp), PARAMETER :: z0_ice = 1.00e-3_wp ! Eq. 15 [m] + REAL(wp), PARAMETER :: zce10 = 2.80e-3_wp ! Eq. 41 + REAL(wp), PARAMETER :: zbeta = 1.1_wp ! Eq. 41 + REAL(wp), PARAMETER :: zc = 5._wp ! Eq. 13 + REAL(wp), PARAMETER :: zc2 = zc * zc + REAL(wp), PARAMETER :: zam = 2. * zc ! Eq. 14 + REAL(wp), PARAMETER :: zah = 3. * zc ! Eq. 30 + REAL(wp), PARAMETER :: z1_alpha = 1._wp / 0.2_wp ! Eq. 51 + REAL(wp), PARAMETER :: z1_alphaf = z1_alpha ! Eq. 56 + REAL(wp), PARAMETER :: zbetah = 1.e-3_wp ! Eq. 26 + REAL(wp), PARAMETER :: zgamma = 1.25_wp ! Eq. 26 + REAL(wp), PARAMETER :: z1_gamma = 1._wp / zgamma + REAL(wp), PARAMETER :: r1_3 = 1._wp / 3._wp + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zthetav_os, zthetav_is, zthetav_zu + REAL(wp) :: zrib_o, zrib_i + REAL(wp) :: zCdn_skin_ice, zCdn_form_ice, zCdn_ice + REAL(wp) :: zChn_skin_ice, zChn_form_ice + REAL(wp) :: z0w, z0i, zfmi, zfmw, zfhi, zfhw + REAL(wp) :: zCdn_form_tmp + !!---------------------------------------------------------------------- + + ! mean temperature + WHERE( at_i_b(:,:) > 1.e-20 ) ; ztm_su(:,:) = SUM( t_su(:,:,:) * a_i_b(:,:,:) , dim=3 ) / at_i_b(:,:) + ELSEWHERE ; ztm_su(:,:) = rt0 + ENDWHERE + + ! Momentum Neutral Transfert Coefficients (should be a constant) + zCdn_form_tmp = zce10 * ( LOG( 10._wp / z0_form_ice + 1._wp ) / LOG( rn_zu / z0_form_ice + 1._wp ) )**2 ! Eq. 40 + zCdn_skin_ice = ( vkarmn / LOG( rn_zu / z0_skin_ice + 1._wp ) )**2 ! Eq. 7 + zCdn_ice = zCdn_skin_ice ! Eq. 7 (cf Lupkes email for details) + !zCdn_ice = 1.89e-3 ! old ECHAM5 value (cf Eq. 32) + + ! Heat Neutral Transfert Coefficients + zChn_skin_ice = vkarmn**2 / ( LOG( rn_zu / z0_ice + 1._wp ) * LOG( rn_zu * z1_alpha / z0_skin_ice + 1._wp ) ) ! Eq. 50 + Eq. 52 (cf Lupkes email for details) + + ! Atmospheric and Surface Variables + zst(:,:) = sst_m(:,:) + rt0 ! convert SST from Celcius to Kelvin + zqo_sat(:,:) = 0.98_wp * q_sat( zst(:,:) , sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ocean [kg/kg] + zqi_sat(:,:) = 0.98_wp * q_sat( ztm_su(:,:), sf(jp_slp)%fnow(:,:,1) ) ! saturation humidity over ice [kg/kg] + ! + DO jj = 2, jpjm1 ! reduced loop is necessary for reproducibility + DO ji = fs_2, fs_jpim1 + ! Virtual potential temperature [K] + zthetav_os = zst(ji,jj) * ( 1._wp + rctv0 * zqo_sat(ji,jj) ) ! over ocean + zthetav_is = ztm_su(ji,jj) * ( 1._wp + rctv0 * zqi_sat(ji,jj) ) ! ocean ice + zthetav_zu = t_zu (ji,jj) * ( 1._wp + rctv0 * q_zu(ji,jj) ) ! at zu + + ! Bulk Richardson Number (could use Ri_bulk function from aerobulk instead) + zrib_o = grav / zthetav_os * ( zthetav_zu - zthetav_os ) * rn_zu / MAX( 0.5, wndm(ji,jj) )**2 ! over ocean + zrib_i = grav / zthetav_is * ( zthetav_zu - zthetav_is ) * rn_zu / MAX( 0.5, wndm_ice(ji,jj) )**2 ! over ice + + ! Momentum and Heat Neutral Transfert Coefficients + zCdn_form_ice = zCdn_form_tmp * at_i_b(ji,jj) * ( 1._wp - at_i_b(ji,jj) )**zbeta ! Eq. 40 + zChn_form_ice = zCdn_form_ice / ( 1._wp + ( LOG( z1_alphaf ) / vkarmn ) * SQRT( zCdn_form_ice ) ) ! Eq. 53 + + ! Momentum and Heat Stability functions (possibility to use psi_m_ecmwf instead) + z0w = rn_zu * EXP( -1._wp * vkarmn / SQRT( Cdn_oce(ji,jj) ) ) ! over water + z0i = z0_skin_ice ! over ice (cf Lupkes email for details) + IF( zrib_o <= 0._wp ) THEN + zfmw = 1._wp - zam * zrib_o / ( 1._wp + 3._wp * zc2 * Cdn_oce(ji,jj) * SQRT( -zrib_o * ( rn_zu / z0w + 1._wp ) ) ) ! Eq. 10 + zfhw = ( 1._wp + ( zbetah * ( zthetav_os - zthetav_zu )**r1_3 / ( Chn_oce(ji,jj) * MAX(0.01, wndm(ji,jj)) ) & ! Eq. 26 + & )**zgamma )**z1_gamma + ELSE + zfmw = 1._wp / ( 1._wp + zam * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 12 + zfhw = 1._wp / ( 1._wp + zah * zrib_o / SQRT( 1._wp + zrib_o ) ) ! Eq. 28 + ENDIF + + IF( zrib_i <= 0._wp ) THEN + zfmi = 1._wp - zam * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 9 + zfhi = 1._wp - zah * zrib_i / (1._wp + 3._wp * zc2 * zCdn_ice * SQRT( -zrib_i * ( rn_zu / z0i + 1._wp))) ! Eq. 25 + ELSE + zfmi = 1._wp / ( 1._wp + zam * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 11 + zfhi = 1._wp / ( 1._wp + zah * zrib_i / SQRT( 1._wp + zrib_i ) ) ! Eq. 27 + ENDIF + + ! Momentum Transfert Coefficients (Eq. 38) + Cd(ji,jj) = zCdn_skin_ice * zfmi + & + & zCdn_form_ice * ( zfmi * at_i_b(ji,jj) + zfmw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) + + ! Heat Transfert Coefficients (Eq. 49) + Ch(ji,jj) = zChn_skin_ice * zfhi + & + & zChn_form_ice * ( zfhi * at_i_b(ji,jj) + zfhw * ( 1._wp - at_i_b(ji,jj) ) ) / MAX( 1.e-06, at_i_b(ji,jj) ) + ! + END DO + END DO + CALL lbc_lnk_multi( 'sbcblk', Cd, 'T', 1., Ch, 'T', 1. ) + ! + END SUBROUTINE Cdn10_Lupkes2015 + +#endif + + !!====================================================================== +END MODULE sbcblk diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_coare.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_coare.F90 new file mode 100644 index 0000000..623040f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_coare.F90 @@ -0,0 +1,448 @@ +MODULE sbcblk_algo_coare + !!====================================================================== + !! *** MODULE sbcblk_algo_coare *** + !! Computes turbulent components of surface fluxes + !! according to Fairall et al. 2003 (COARE v3) + !! + !! * 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 U_blk + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of COARE v3, Fairall et al. 2003 + !! + !! + !! Routine turb_coare maintained and developed in AeroBulk + !! (http://aerobulk.sourceforge.net/) + !! + !! Author: Laurent Brodeau, 2016, brodeau@gmail.com + !! + !!====================================================================== + !! History : 3.6 ! 2016-02 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_coare : 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 sbc_oce ! Surface boundary condition: ocean fields + USE sbcwave, ONLY : cdn_wave ! wave module +#if defined key_si3 || defined key_cice + USE sbc_ice ! Surface boundary condition: ice fields +#endif + ! + USE in_out_manager ! I/O manager + USE iom ! I/O manager library + USE lib_mpp ! distribued memory computing library + USE prtctl ! Print control + USE lib_fortran ! to use key_nosignedzero + + IMPLICIT NONE + PRIVATE + + PUBLIC :: TURB_COARE ! called by sbcblk.F90 + + ! !! COARE own values for given constants: + REAL(wp), PARAMETER :: zi0 = 600._wp ! scale height of the atmospheric boundary layer... + REAL(wp), PARAMETER :: Beta0 = 1.250_wp ! gustiness parameter + REAL(wp), PARAMETER :: rctv0 = 0.608_wp ! constant to obtain virtual temperature... + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_coare( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, U_blk, & + & Cdn, Chn, Cen ) + !!---------------------------------------------------------------------- + !! *** ROUTINE turb_coare *** + !! + !! 2015: L. Brodeau (brodeau@gmail.com) + !! + !! ** 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 + !! + !! ** Method : Monin Obukhov Similarity Theory + !!---------------------------------------------------------------------- + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (generally 10m) [m] + !! * U_zu : scalar wind speed at 10m [m/s] + !! * sst : 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] + !! + !! + !! 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] + !! * U_blk : bulk wind at 10m [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) :: U_blk ! bulk wind at 10m [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients + ! + INTEGER :: j_itt + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + INTEGER , PARAMETER :: nb_itt = 4 ! number of itterations + + REAL(wp), DIMENSION(jpi,jpj) :: & + & u_star, t_star, q_star, & + & dt_zu, dq_zu, & + & znu_a, & !: Nu_air, Viscosity of air + & 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(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + !!---------------------------------------------------------------------- + ! + l_zt_equal_zu = .FALSE. + IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision + + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! First guess of temperature and humidity at height zu: + t_zu = MAX(t_zt , 0.0) ! who knows what's given on masked-continental regions... + q_zu = MAX(q_zt , 1.e-6) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + + znu_a = visc_air(t_zt) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + ztmp2 = 0.5*0.5 ! initial guess for wind gustiness contribution + U_blk = SQRT(U_zu*U_zu + ztmp2) + + ztmp2 = 10000. ! optimization: ztmp2 == 1/z0 (with z0 first guess == 0.0001) + ztmp0 = LOG(zu*ztmp2) + ztmp1 = LOG(10.*ztmp2) + u_star = 0.035*U_blk*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + + z0 = alfa_charn(U_blk)*u_star*u_star/grav + 0.11*znu_a/u_star + z0t = 0.1*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ! WARNING: 1/z0t ! + + ztmp2 = vkarmn/ztmp0 + Cd = ztmp2*ztmp2 ! first guess of Cd + + ztmp0 = vkarmn*vkarmn/LOG(zt*z0t)/Cd + + !Ribcu = -zu/(zi0*0.004*Beta0**3) !! Saturation Rib, zi0 = tropicalbound. layer depth + ztmp2 = grav*zu*(dt_zu + rctv0*t_zu*dq_zu)/(t_zu*U_blk*U_blk) !! Ribu Bulk Richardson number + ztmp1 = 0.5 + sign(0.5 , ztmp2) + ztmp0 = ztmp0*ztmp2 + !! Ribu < 0 Ribu > 0 Beta = 1.25 + zeta_u = (1.-ztmp1) * (ztmp0/(1.+ztmp2/(-zu/(zi0*0.004*Beta0**3)))) & + & + ztmp1 * (ztmp0*(1. + 27./9.*ztmp2/ztmp0)) + + !! 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 = U_blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What's need to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + + zeta_t = zt*zeta_u/zu + + !! First update of values at zu (or zt for wind) + 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 + sign(0.5,q_zu))*q_zu !Makes it impossible to have negative humidity : + + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + + END IF + + !! ITERATION BLOCK + DO j_itt = 1, nb_itt + + !!Inverse of Monin-Obukov length (1/L) : + ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Monin-Obukhov length] + + ztmp1 = u_star*u_star ! u*^2 + + !! Update wind at 10m taking into acount convection-related wind gustiness: + ! Ug = Beta*w* (Beta = 1.25, Fairall et al. 2003, Eq.8): + ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0.))**(2./3.) ! => ztmp2 == Ug^2 + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before 600. + U_blk = MAX(sqrt(U_zu*U_zu + ztmp2), 0.2) ! include gustiness in bulk wind speed + ! => 0.2 prevents U_blk to be 0 in stable case when U_zu=0. + + !! Updating Charnock parameter, increases with the wind (Fairall et al., 2003 p. 577-578) + ztmp2 = alfa_charn(U_blk) ! alpha Charnock parameter + + !! Roughness lengthes z0, z0t (z0q = z0t) : + z0 = ztmp2*ztmp1/grav + 0.11*znu_a/u_star ! Roughness length (eq.6) + ztmp1 = z0*u_star/znu_a ! Re_r: roughness Reynolds number + z0t = min( 1.1E-4 , 5.5E-5*ztmp1**(-0.6) ) ! Scalar roughness for both theta and q (eq.28) + + !! Stability parameters: + zeta_u = zu*ztmp0 ; zeta_u = sign( min(abs(zeta_u),50.0), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 ; zeta_t = sign( min(abs(zeta_t),50.0), zeta_t ) + END IF + + !! Turbulent scales at zu=10m : + ztmp0 = psi_h_coare(zeta_u) + ztmp1 = vkarmn/(LOG(zu) -LOG(z0t) - ztmp0) + + t_star = dt_zu*ztmp1 + q_star = dq_zu*ztmp1 + u_star = U_blk*vkarmn/(LOG(zu) -LOG(z0) - psi_m_coare(zeta_u)) + + IF( .NOT. l_zt_equal_zu ) THEN + ! What's need to be done if zt /= zu + !! Re-updating temperature and humidity at zu : + ztmp2 = ztmp0 - psi_h_coare(zeta_t) + ztmp1 = log(zt/zu) + ztmp2 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + END IF + + END DO + ! + ! compute transfer coefficients at zu : + ztmp0 = u_star/U_blk + Cd = ztmp0*ztmp0 + Ch = ztmp0*t_star/dt_zu + Ce = ztmp0*q_star/dq_zu + ! + ztmp1 = zu + z0 + Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) + Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) + Cen = Chn + ! + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + ! + END SUBROUTINE turb_coare + + + FUNCTION alfa_charn( 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://sourceforge.net/p/aerobulk) + !!------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: alfa_charn + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pwnd ! wind speed + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zw, zgt10, zgt18 + !!------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zw = pwnd(ji,jj) ! wind speed + ! + ! Charnock's constant, increases with the wind : + zgt10 = 0.5 + SIGN(0.5,(zw - 10.)) ! If zw<10. --> 0, else --> 1 + zgt18 = 0.5 + SIGN(0.5,(zw - 18.)) ! If zw<18. --> 0, else --> 1 + ! + alfa_charn(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 alfa_charn + + + FUNCTION One_on_L( ptha, pqa, pus, pts, pqs ) + !!------------------------------------------------------------------------ + !! + !! Evaluates the 1./(Monin Obukhov length) from air temperature and + !! specific humidity, and frictional scales u*, t* and q* + !! + !! Author: L. Brodeau, june 2016 / AeroBulk + !! (https://sourceforge.net/p/aerobulk) + !!------------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Monin Obukhov length) [m^-1] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha, & !: average potetntial air temperature [K] + & pqa, & !: average specific humidity of air [kg/kg] + & pus, pts, pqs !: frictional velocity, temperature and humidity + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zqa ! local scalar + !!------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zqa = (1. + rctv0*pqa(ji,jj)) + ! + One_on_L(ji,jj) = grav*vkarmn*(pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj)) & + & / ( pus(ji,jj)*pus(ji,jj) * ptha(ji,jj)*zqa ) + ! + END DO + END DO + ! + END FUNCTION One_on_L + + + 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://sourceforge.net/p/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 = 1, jpj + DO ji = 1, jpi + ! + 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., 0.35*zta) + zstab = 0.5 + SIGN(0.5, 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://sourceforge.net/p/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 = 1, jpj + DO ji = 1, jpi + ! + 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.,0.35*zta) + zstab = 0.5 + SIGN(0.5, 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 + + + FUNCTION visc_air( ptak ) + !!--------------------------------------------------------------------- + !! Air kinetic viscosity (m^2/s) given from temperature in degrees... + !! + !! Author: L. Brodeau, june 2016 / AeroBulk + !! (https://sourceforge.net/p/aerobulk) + !!--------------------------------------------------------------------- + !! + REAL(wp), DIMENSION(jpi,jpj) :: visc_air + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ztc, ztc2 ! local scalar + ! + DO jj = 1, jpj + DO ji = 1, jpi + ztc = ptak(ji,jj) - rt0 ! air temp, in deg. C + ztc2 = ztc*ztc + visc_air(ji,jj) = 1.326E-5*(1. + 6.542E-3*ztc + 8.301E-6*ztc2 - 4.84E-9*ztc2*ztc) + END DO + END DO + ! + END FUNCTION visc_air + + +END MODULE sbcblk_algo_coare diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_coare3p5.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_coare3p5.F90 new file mode 100644 index 0000000..4724230 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_coare3p5.F90 @@ -0,0 +1,417 @@ +MODULE sbcblk_algo_coare3p5 + !!====================================================================== + !! *** MODULE sbcblk_algo_coare3p5 *** + !! Computes turbulent components of surface fluxes + !! according to Edson et al. 2013 (COARE v3.5) /JPO + !! + !! * 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 U_blk + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of COARE v3.5, Edson et al. 2013 + !! + !! + !! Routine turb_coare3p5 maintained and developed in AeroBulk + !! (http://aerobulk.sourceforge.net/) + !! + !! Author: Laurent Brodeau, 2016, brodeau@gmail.com + !! + !!====================================================================== + !! History : 3.6 ! 2016-02 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! turb_coare3p5 : 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 sbc_oce ! Surface boundary condition: ocean fields + USE sbcwave, ONLY : cdn_wave ! wave module +#if defined key_si3 || defined key_cice + USE sbc_ice ! Surface boundary condition: ice fields +#endif + ! + 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 lib_fortran ! to use key_nosignedzero + + IMPLICIT NONE + PRIVATE + + PUBLIC :: TURB_COARE3P5 ! called by sbcblk.F90 + + ! ! COARE own values for given constants: + REAL(wp), PARAMETER :: charn0_max = 0.028 ! value above which the Charnock paramter levels off for winds > 18 + REAL(wp), PARAMETER :: zi0 = 600. ! scale height of the atmospheric boundary layer...1 + REAL(wp), PARAMETER :: Beta0 = 1.25 ! gustiness parameter + REAL(wp), PARAMETER :: rctv0 = 0.608 ! constant to obtain virtual temperature... + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_coare3p5( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, U_blk, & + & Cdn, Chn, Cen ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_coare3p5 *** + !! + !! ** 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 + !! + !! ** Method : Monin Obukhov Similarity Theory + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (generally 10m) [m] + !! * U_zu : scalar wind speed at 10m [m/s] + !! * sst : 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] + !! + !! + !! 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] + !! * U_blk : bulk wind at 10m [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 [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) :: U_blk ! bulk wind at 10m [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients + ! + INTEGER :: j_itt + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + INTEGER , PARAMETER :: nb_itt = 4 ! number of itterations + ! + REAL(wp), DIMENSION(jpi,jpj) :: & + & u_star, t_star, q_star, & + & dt_zu, dq_zu, & + & znu_a, & !: Nu_air, Viscosity of air + & 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(:,:), ALLOCATABLE :: zeta_t ! stability parameter at height zt + !!---------------------------------------------------------------------------------- + ! + l_zt_equal_zu = .FALSE. + IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision + + IF( .NOT. l_zt_equal_zu ) ALLOCATE( zeta_t(jpi,jpj) ) + + !! First guess of temperature and humidity at height zu: + t_zu = MAX(t_zt , 0.0) ! who knows what's given on masked-continental regions... + q_zu = MAX(q_zt , 1.E-6) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + + znu_a = visc_air(t_zt) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + ztmp2 = 0.5*0.5 ! initial guess for wind gustiness contribution + U_blk = SQRT(U_zu*U_zu + ztmp2) + + ztmp2 = 10000. ! optimization: ztmp2 == 1/z0 (with z0 first guess == 0.0001) + ztmp0 = LOG(zu*ztmp2) + ztmp1 = LOG(10.*ztmp2) + u_star = 0.035*U_blk*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + !! COARE 3.5 first guess of UN10 is U_zu + ztmp2 = MIN( 0.0017*U_zu - 0.005 , charn0_max) ! alpha Charnock parameter (Eq. 13 Edson al. 2013) + ztmp2 = MAX( ztmp2 , 0. ) ! alpha Charnock parameter (Eq. 13 Edson al. 2013) + z0 = ztmp2*u_star*u_star/grav + 0.11*znu_a/u_star + z0t = 0.1*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ! WARNING: 1/z0t ! + + ztmp2 = vkarmn/ztmp0 + Cd = ztmp2*ztmp2 ! first guess of Cd + + ztmp0 = vkarmn*vkarmn/LOG(zt*z0t)/Cd + + !Ribcu = -zu/(zi0*0.004*Beta0**3) !! Saturation Rib, zi0 = tropicalbound. layer depth + ztmp2 = grav*zu*(dt_zu + rctv0*t_zu*dq_zu)/(t_zu*U_blk*U_blk) !! Ribu Bulk Richardson number + ztmp1 = 0.5 + sign(0.5 , ztmp2) + ztmp0 = ztmp0*ztmp2 + !! Ribu < 0 Ribu > 0 Beta = 1.25 + zeta_u = (1.-ztmp1) * (ztmp0/(1.+ztmp2/(-zu/(zi0*0.004*Beta0**3)))) & + & + ztmp1 * (ztmp0*(1. + 27./9.*ztmp2/ztmp0)) + + !! 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 = U_blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_coare(zeta_u)) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What's need to be done if zt /= zu: + IF( .NOT. l_zt_equal_zu ) THEN + + zeta_t = zt*zeta_u/zu + + !! First update of values at zu (or zt for wind) + 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 + sign(0.5,q_zu))*q_zu !Makes it impossible to have negative humidity : + + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + + END IF + + !! ITERATION BLOCK + DO j_itt = 1, nb_itt + + !!Inverse of Monin-Obukov length (1/L) : + ztmp0 = One_on_L(t_zu, q_zu, u_star, t_star, q_star) ! 1/L == 1/[Monin-Obukhov length] + + ztmp1 = u_star*u_star ! u*^2 + + !! Update wind at 10m taking into acount convection-related wind gustiness: + ! Ug = Beta*w* (Beta = 1.25, Fairall et al. 2003, Eq.8): + ztmp2 = Beta0*Beta0*ztmp1*(MAX(-zi0*ztmp0/vkarmn,0.))**(2./3.) ! => ztmp2 == Ug^2 + !! ! Only true when unstable (L<0) => when ztmp0 < 0 => explains "-" before 600. + U_blk = MAX(sqrt(U_zu*U_zu + ztmp2), 0.2) ! include gustiness in bulk wind speed + ! => 0.2 prevents U_blk to be 0 in stable case when U_zu=0. + + !! COARE 3.5: Charnock parameter is computed from the neutral wind speed at 10m: Eq. 13 (Edson al. 2013) + ztmp2 = u_star/vkarmn*LOG(10./z0) ! UN10 Neutral wind at 10m! + ztmp2 = MIN( 0.0017*ztmp2 - 0.005 , charn0_max) ! alpha Charnock parameter (Eq. 13 Edson al. 2013) + ztmp2 = MAX( ztmp2 , 0. ) + + !! Roughness lengthes z0, z0t (z0q = z0t) : + z0 = ztmp2*ztmp1/grav + 0.11*znu_a/u_star ! Roughness length (eq.6) + ztmp1 = z0*u_star/znu_a ! Re_r: roughness Reynolds number + !z0t = MIN( 1.1E-4 , 5.5E-5*ztmp1**(-0.6) ) ! COARE 3.0 + !! Chris Fairall and Jim Edsson, private communication, March 2016 / COARE 3.5 : + z0t = MIN( 1.6e-4 , 5.8E-5*ztmp1**(-0.72)) ! These thermal roughness lengths give Stanton and + !z0q = z0t ! Dalton numbers that closely approximate COARE3.0 + + !! Stability parameters: + zeta_u = zu*ztmp0 ; zeta_u = sign( min(abs(zeta_u),50.0), zeta_u ) + IF( .NOT. l_zt_equal_zu ) THEN + zeta_t = zt*ztmp0 ; zeta_t = sign( min(abs(zeta_t),50.0), zeta_t ) + END IF + + !! Turbulent scales at zu=10m : + ztmp0 = psi_h_coare(zeta_u) + ztmp1 = vkarmn/(LOG(zu) -LOG(z0t) - ztmp0) + + t_star = dt_zu*ztmp1 + q_star = dq_zu*ztmp1 + u_star = U_blk*vkarmn/(LOG(zu) -LOG(z0) - psi_m_coare(zeta_u)) + + IF( .NOT. l_zt_equal_zu ) THEN + ! What's need to be done if zt /= zu + !! Re-updating temperature and humidity at zu : + ztmp2 = ztmp0 - psi_h_coare(zeta_t) + ztmp1 = log(zt/zu) + ztmp2 + t_zu = t_zt - t_star/vkarmn*ztmp1 + q_zu = q_zt - q_star/vkarmn*ztmp1 + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + END IF + + END DO + ! + ! compute transfer coefficients at zu : + ztmp0 = u_star/U_blk + Cd = ztmp0*ztmp0 + Ch = ztmp0*t_star/dt_zu + Ce = ztmp0*q_star/dq_zu + ! + ztmp1 = zu + z0 + Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) + Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) + Cen = Chn + ! + IF( .NOT. l_zt_equal_zu ) DEALLOCATE( zeta_t ) + ! + END SUBROUTINE turb_coare3p5 + + + + FUNCTION One_on_L( ptha, pqa, pus, pts, pqs ) + !!------------------------------------------------------------------------ + !! + !! Evaluates the 1./(Monin Obukhov length) from air temperature and + !! specific humidity, and frictional scales u*, t* and q* + !! + !! Author: L. Brodeau, june 2016 / AeroBulk + !! (https://sourceforge.net/p/aerobulk) + !!------------------------------------------------------------------------ + REAL(wp), DIMENSION(jpi,jpj) :: One_on_L !: 1./(Monin Obukhov length) [m^-1] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptha, & !: average potetntial air temperature [K] + & pqa, & !: average specific humidity of air [kg/kg] + & pus, pts, pqs !: frictional velocity, temperature and humidity + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: zqa ! local scalar + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zqa = (1. + rctv0*pqa(ji,jj)) + ! + One_on_L(ji,jj) = grav*vkarmn*(pts(ji,jj)*zqa + rctv0*ptha(ji,jj)*pqs(ji,jj)) & + & / ( pus(ji,jj)*pus(ji,jj) * ptha(ji,jj)*zqa ) + ! + END DO + END DO + ! + END FUNCTION One_on_L + + + 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://sourceforge.net/p/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 = 1, jpj + DO ji = 1, jpi + ! + 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., 0.35*zta) + zstab = 0.5 + SIGN(0.5, 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://sourceforge.net/p/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 = 1, jpj + DO ji = 1, jpi + ! + 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.,0.35*zta) + zstab = 0.5 + SIGN(0.5, 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 + + + FUNCTION visc_air( ptak ) + !!--------------------------------------------------------------------- + !! Air kinetic viscosity (m^2/s) given from temperature in degrees... + !! + !! Author: L. Brodeau, june 2016 / AeroBulk + !! (https://sourceforge.net/p/aerobulk) + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: visc_air + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature [K] + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ztc, ztc2 ! local scalar + ! + DO jj = 1, jpj + DO ji = 1, jpi + ztc = ptak(ji,jj) - rt0 ! air temp, in deg. C + ztc2 = ztc*ztc + visc_air(ji,jj) = 1.326E-5*(1. + 6.542E-3*ztc + 8.301E-6*ztc2 - 4.84E-9*ztc2*ztc) + END DO + END DO + ! + END FUNCTION visc_air + + !!====================================================================== +END MODULE sbcblk_algo_coare3p5 diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_ecmwf.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_ecmwf.F90 new file mode 100644 index 0000000..d7d1d26 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_ecmwf.F90 @@ -0,0 +1,427 @@ +MODULE sbcblk_algo_ecmwf + !!====================================================================== + !! *** MODULE sbcblk_algo_ecmwf *** + !! Computes turbulent components of surface fluxes + !! according to the method in IFS of the ECMWF model + !! + !! * 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 U_blk + !! => all these are used in bulk formulas in sbcblk.F90 + !! + !! Using the bulk formulation/param. of IFS of ECMWF (cycle 31r2) + !! based on IFS doc (avaible online on the ECMWF's website) + !! + !! + !! Routine turb_ecmwf maintained and developed in AeroBulk + !! (http://aerobulk.sourceforge.net/) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !!---------------------------------------------------------------------- + !! History : 4.0 ! 2016-02 (L.Brodeau) Original code + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 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 +#if defined key_si3 || defined key_cice + USE sbc_ice ! Surface boundary condition: ice fields +#endif + USE lib_fortran ! to use key_nosignedzero + + USE sbc_oce ! Surface boundary condition: ocean fields + + IMPLICIT NONE + PRIVATE + + PUBLIC :: TURB_ECMWF ! called by sbcblk.F90 + + ! !! ECMWF own values for given constants, taken form IFS documentation... + REAL(wp), PARAMETER :: charn0 = 0.018 ! 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 :: rctv0 = 0.608 ! constant to obtain virtual temperature... + REAL(wp), PARAMETER :: Cp_dry = 1005.0 ! Specic heat of dry air, constant pressure [J/K/kg] + REAL(wp), PARAMETER :: Cp_vap = 1860.0 ! Specic heat of water vapor, constant pressure [J/K/kg] + 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 ! + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE TURB_ECMWF( zt, zu, sst, t_zt, ssq , q_zt , U_zu, & + & Cd, Ch, Ce , t_zu, q_zu, U_blk, & + & Cdn, Chn, Cen ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE turb_ecmwf *** + !! + !! 2015: L. Brodeau (brodeau@gmail.com) + !! + !! ** Purpose : Computes turbulent transfert coefficients of surface + !! fluxes according to IFS doc. (cycle 31) + !! If relevant (zt /= zu), adjust temperature and humidity from height zt to zu + !! + !! ** Method : Monin Obukhov Similarity Theory + !! + !! INPUT : + !! ------- + !! * zt : height for temperature and spec. hum. of air [m] + !! * zu : height for wind speed (generally 10m) [m] + !! * U_zu : scalar wind speed at 10m [m/s] + !! * sst : 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] + !! + !! + !! 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] + !! * U_blk : bulk wind at 10m [m/s] + !! + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/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 [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) :: U_blk ! bulk wind at 10m [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: Cdn, Chn, Cen ! neutral transfer coefficients + ! + INTEGER :: j_itt + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + INTEGER , PARAMETER :: nb_itt = 4 ! number of itterations + ! + REAL(wp), DIMENSION(jpi,jpj) :: u_star, t_star, q_star, & + & dt_zu, dq_zu, & + & znu_a, & !: Nu_air, Viscosity of air + & Linv, & !: 1/L (inverse of Monin Obukhov length... + & z0, z0t, z0q + REAL(wp), DIMENSION(jpi,jpj) :: func_m, func_h + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + !!---------------------------------------------------------------------------------- + ! + ! Identical first gess as in COARE, with IFS parameter values though + ! + l_zt_equal_zu = .FALSE. + IF( ABS(zu - zt) < 0.01 ) l_zt_equal_zu = .TRUE. ! testing "zu == zt" is risky with double precision + + + !! First guess of temperature and humidity at height zu: + t_zu = MAX( t_zt , 0.0 ) ! who knows what's given on masked-continental regions... + q_zu = MAX( q_zt , 1.e-6) ! " + + !! Pot. temp. difference (and we don't want it to be 0!) + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.e-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.e-9), dq_zu ) + + znu_a = visc_air(t_zt) ! Air viscosity (m^2/s) at zt given from temperature in (K) + + ztmp2 = 0.5 * 0.5 ! initial guess for wind gustiness contribution + U_blk = SQRT(U_zu*U_zu + ztmp2) + + ! z0 = 0.0001 + ztmp2 = 10000. ! optimization: ztmp2 == 1/z0 + ztmp0 = LOG(zu*ztmp2) + ztmp1 = LOG(10.*ztmp2) + u_star = 0.035*U_blk*ztmp1/ztmp0 ! (u* = 0.035*Un10) + + z0 = charn0*u_star*u_star/grav + 0.11*znu_a/u_star + z0t = 0.1*EXP(vkarmn/(0.00115/(vkarmn/ztmp1))) ! WARNING: 1/z0t ! + + Cd = (vkarmn/ztmp0)**2 ! first guess of Cd + + ztmp0 = vkarmn*vkarmn/LOG(zt*z0t)/Cd + + ztmp2 = Ri_bulk( zu, t_zu, dt_zu, q_zu, dq_zu, U_blk ) ! Ribu = Bulk Richardson number + + !! First estimate of zeta_u, depending on the stability, ie sign of Ribu (ztmp2): + ztmp1 = 0.5 + SIGN( 0.5 , ztmp2 ) + func_m = ztmp0*ztmp2 ! temporary array !! + !! Ribu < 0 Ribu > 0 Beta = 1.25 + func_h = (1.-ztmp1)*(func_m/(1.+ztmp2/(-zu/(zi0*0.004*Beta0**3)))) & ! temporary array !!! func_h == zeta_u + & + ztmp1*(func_m*(1. + 27./9.*ztmp2/ztmp0)) + + !! 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 = U_blk*vkarmn/(LOG(zu) - LOG(z0) - psi_m_ecmwf(func_h)) + t_star = dt_zu*ztmp0 + q_star = dq_zu*ztmp0 + + ! What's need 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 + sign(0.5,q_zu))*q_zu !Makes it impossible to have negative humidity : + + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + ! + ENDIF + + + !! => that was same first guess as in COARE... + + + !! First guess of inverse of Monin-Obukov length (1/L) : + ztmp0 = (1. + rctv0*q_zu) ! the factor to apply to temp. to get virt. temp... + Linv = grav*vkarmn*(t_star*ztmp0 + rctv0*t_zu*q_star) / ( u_star*u_star * t_zu*ztmp0 ) + + !! Functions such as u* = U_blk*vkarmn/func_m + ztmp1 = zu + z0 + ztmp0 = ztmp1*Linv + func_m = LOG(ztmp1) -LOG(z0) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0*Linv) + func_h = LOG(ztmp1*z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(1./z0t*Linv) + + + !! ITERATION BLOCK + !! *************** + + DO j_itt = 1, nb_itt + + !! Bulk Richardson Number at z=zu (Eq. 3.25) + ztmp0 = Ri_bulk(zu, t_zu, dt_zu, q_zu, dq_zu, U_blk) + + !! New estimate of the inverse of the Monin-Obukhon length (Linv == zeta/zu) : + Linv = ztmp0*func_m*func_m/func_h / zu ! From Eq. 3.23, Chap.3, p.33, IFS doc - Cy31r1 + + !! Update func_m with new Linv: + ztmp1 = zu + z0 + func_m = LOG(ztmp1) -LOG(z0) - psi_m_ecmwf(ztmp1*Linv) + psi_m_ecmwf(z0*Linv) + + !! Need to update roughness lengthes: + u_star = U_blk*vkarmn/func_m + ztmp2 = u_star*u_star + ztmp1 = znu_a/u_star + z0 = alpha_M*ztmp1 + charn0*ztmp2/grav + z0t = alpha_H*ztmp1 ! eq.3.26, Chap.3, p.34, IFS doc - Cy31r1 + z0q = alpha_Q*ztmp1 + + !! Update wind at 10m taking into acount convection-related wind gustiness: + ! Only true when unstable (L<0) => when ztmp0 < 0 => - !!! + ztmp2 = ztmp2 * (MAX(-zi0*Linv/vkarmn,0.))**(2./3.) ! => w*^2 (combining Eq. 3.8 and 3.18, hap.3, IFS doc - Cy31r1) + !! => equivalent using Beta=1 (gustiness parameter, 1.25 for COARE, also zi0=600 in COARE..) + U_blk = MAX(sqrt(U_zu*U_zu + ztmp2), 0.2) ! eq.3.17, Chap.3, p.32, IFS doc - Cy31r1 + ! => 0.2 prevents U_blk 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+z0)*Linv) ! temporary array !!! + func_m = psi_h_ecmwf((zt+z0)*Linv) ! temporary array !!! + + ztmp2 = psi_h_ecmwf(z0t*Linv) + ztmp0 = func_h - ztmp2 + ztmp1 = vkarmn/(LOG(zu+z0) - 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+z0) - 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 + + dt_zu = t_zu - sst ; dt_zu = SIGN( MAX(ABS(dt_zu),1.E-6), dt_zu ) + dq_zu = q_zu - ssq ; dq_zu = SIGN( MAX(ABS(dq_zu),1.E-9), dq_zu ) + + END IF + + !! Updating because of updated z0 and z0t and new Linv... + ztmp1 = zu + z0 + ztmp0 = ztmp1*Linv + func_m = log(ztmp1) - LOG(z0 ) - psi_m_ecmwf(ztmp0) + psi_m_ecmwf(z0 *Linv) + func_h = log(ztmp1) - LOG(z0t) - psi_h_ecmwf(ztmp0) + psi_h_ecmwf(z0t*Linv) + + END DO + + Cd = vkarmn*vkarmn/(func_m*func_m) + Ch = vkarmn*vkarmn/(func_m*func_h) + ztmp1 = log((zu + z0)/z0q) - psi_h_ecmwf((zu + z0)*Linv) + psi_h_ecmwf(z0q*Linv) ! func_q + Ce = vkarmn*vkarmn/(func_m*ztmp1) + + ztmp1 = zu + z0 + Cdn = vkarmn*vkarmn / (log(ztmp1/z0 )*log(ztmp1/z0 )) + Chn = vkarmn*vkarmn / (log(ztmp1/z0t)*log(ztmp1/z0t)) + Cen = vkarmn*vkarmn / (log(ztmp1/z0q)*log(ztmp1/z0q)) + + 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://sourceforge.net/p/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) :: zzeta, zx, ztmp, psi_unst, psi_stab, stab + !!---------------------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zzeta = MIN( pzeta(ji,jj) , 5. ) !! Very stable conditions (L positif and big!): + ! + ! Unstable (Paulson 1970): + ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 + zx = SQRT(ABS(1. - 16.*zzeta)) + ztmp = 1. + SQRT(zx) + ztmp = ztmp*ztmp + psi_unst = LOG( 0.125*ztmp*(1. + zx) ) & + & -2.*ATAN( SQRT(zx) ) + 0.5*rpi + ! + ! Unstable: + ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 + psi_stab = -2./3.*(zzeta - 5./0.35)*EXP(-0.35*zzeta) & + & - zzeta - 2./3.*5./0.35 + ! + ! Combining: + stab = 0.5 + SIGN(0.5, zzeta) ! zzeta > 0 => stab = 1 + ! + psi_m_ecmwf(ji,jj) = (1. - stab) * psi_unst & ! (zzeta < 0) Unstable + & + stab * psi_stab ! (zzeta > 0) Stable + ! + 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://sourceforge.net/p/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) :: zzeta, zx, psi_unst, psi_stab, stab + !!---------------------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zzeta = MIN(pzeta(ji,jj) , 5.) ! Very stable conditions (L positif and big!): + ! + zx = ABS(1. - 16.*zzeta)**.25 ! this is actually (1/phi_m)**2 !!! + ! ! eq.3.19, Chap.3, p.33, IFS doc - Cy31r1 + ! Unstable (Paulson 1970) : + psi_unst = 2.*LOG(0.5*(1. + zx*zx)) ! eq.3.20, Chap.3, p.33, IFS doc - Cy31r1 + ! + ! Stable: + psi_stab = -2./3.*(zzeta - 5./0.35)*EXP(-0.35*zzeta) & ! eq.3.22, Chap.3, p.33, IFS doc - Cy31r1 + & - ABS(1. + 2./3.*zzeta)**1.5 - 2./3.*5./0.35 + 1. + ! LB: added ABS() to avoid NaN values when unstable, which contaminates the unstable solution... + ! + stab = 0.5 + SIGN(0.5, zzeta) ! zzeta > 0 => stab = 1 + ! + ! + psi_h_ecmwf(ji,jj) = (1. - stab) * psi_unst & ! (zzeta < 0) Unstable + & + stab * psi_stab ! (zzeta > 0) Stable + ! + END DO + END DO + ! + END FUNCTION psi_h_ecmwf + + + FUNCTION Ri_bulk( pz, ptz, pdt, pqz, pdq, pub ) + !!---------------------------------------------------------------------------------- + !! Bulk Richardson number (Eq. 3.25 IFS doc) + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: Ri_bulk ! + ! + REAL(wp) , INTENT(in) :: pz ! height above the sea [m] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptz ! air temperature at pz m [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdt ! ptz - sst [K] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pqz ! air temperature at pz m [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pdq ! pqz - ssq [kg/kg] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: pub ! bulk wind speed [m/s] + !!---------------------------------------------------------------------------------- + ! + Ri_bulk = grav*pz/(pub*pub) & + & * ( pdt/(ptz - 0.5_wp*(pdt + grav*pz/(Cp_dry+Cp_vap*pqz))) & + & + rctv0*pdq ) + ! + END FUNCTION Ri_bulk + + + FUNCTION visc_air(ptak) + !!---------------------------------------------------------------------------------- + !! Air kinetic viscosity (m^2/s) given from temperature in degrees... + !! + !! ** Author: L. Brodeau, june 2016 / AeroBulk (https://sourceforge.net/p/aerobulk) + !!---------------------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj) :: visc_air ! + REAL(wp), DIMENSION(jpi,jpj), INTENT(in) :: ptak ! air temperature in (K) + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp) :: ztc, ztc2 ! local scalar + !!---------------------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ztc = ptak(ji,jj) - rt0 ! air temp, in deg. C + ztc2 = ztc*ztc + visc_air(ji,jj) = 1.326e-5*(1. + 6.542E-3*ztc + 8.301e-6*ztc2 - 4.84e-9*ztc2*ztc) + END DO + END DO + ! + END FUNCTION visc_air + + !!====================================================================== +END MODULE sbcblk_algo_ecmwf diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_ncar.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_ncar.F90 new file mode 100644 index 0000000..307e907 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcblk_algo_ncar.F90 @@ -0,0 +1,431 @@ +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 U_blk + !! => 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, 2020 + !!===================================================================== + !! History : 4.0 ! 2020-06 (L.Brodeau) successor of old turb_ncar of former sbcblk_core.F90 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 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 sbcwave, ONLY : cdn_wave ! wave module +#if defined key_si3 || defined key_cice + USE sbc_ice ! Surface boundary condition: ice fields +#endif + ! + 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 lib_fortran ! to use key_nosignedzero + + + IMPLICIT NONE + PRIVATE + + PUBLIC :: TURB_NCAR ! called by sbcblk.F90 + + ! ! NCAR own values for given constants: + REAL(wp), PARAMETER :: rctv0 = 0.608 ! constant to obtain virtual temperature... + + INTEGER , PARAMETER :: nb_itt = 4 ! number of itterations + + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE turb_ncar( zt, zu, sst, t_zt, ssq, q_zt, U_zu, & + & Cd, Ch, Ce, t_zu, q_zu, Ub, & + & 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] + !! * Ub : 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) :: Ub ! bulk wind speed at zu [m/s] + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: CdN, ChN, CeN ! neutral transfer coefficients + ! + INTEGER :: j_itt + LOGICAL :: l_zt_equal_zu = .FALSE. ! if q and t are given at same height as U + ! + REAL(wp), DIMENSION(jpi,jpj) :: Cx_n10 ! 10m neutral latent/sensible coefficient + REAL(wp), DIMENSION(jpi,jpj) :: sqrtCdN10 ! root square of Cd_n10 + REAL(wp), DIMENSION(jpi,jpj) :: zeta_u ! stability parameter at height zu + REAL(wp), DIMENSION(jpi,jpj) :: zpsi_h_u + REAL(wp), DIMENSION(jpi,jpj) :: ztmp0, ztmp1, ztmp2 + REAL(wp), DIMENSION(jpi,jpj) :: sqrtCd + !!---------------------------------------------------------------------------------- + + l_zt_equal_zu = ( ABS(zu - zt) < 0.01_wp ) + + Ub = MAX( 0.5_wp , U_zu ) ! relative wind speed at zu (normally 10m), we don't want to fall under 0.5 m/s + + !! Neutral drag coefficient at zu: + IF( ln_cdgw ) THEN ! wave drag case + CdN = MAX( cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) , 0.1E-3_wp ) + ELSE + CdN = CD_N10_NCAR( Ub ) + ENDIF + sqrtCdN10 = SQRT( CdN ) + + !! Initializing transf. coeff. with their first guess neutral equivalents : + Cd = CdN + Ce = CE_N10_NCAR( sqrtCdN10 ) + ztmp0 = 0.5_wp + SIGN(0.5_wp, virt_temp(t_zt, q_zt) - virt_temp(sst, ssq)) ! we guess stability based on delta of virt. pot. temp. + Ch = CH_N10_NCAR( sqrtCdN10 , ztmp0 ) + sqrtCd = sqrtCdN10 + + !! Initializing values at z_u with z_t values: + t_zu = t_zt + q_zu = q_zt + + !! ITERATION BLOCK + DO j_itt = 1, nb_itt + ! + ztmp1 = t_zu - sst ! Updating air/sea differences + ztmp2 = q_zu - ssq + + ! Updating turbulent scales : (L&Y 2004 Eq. (7)) + ztmp0 = sqrtCd*Ub ! u* + ztmp1 = Ch/sqrtCd*ztmp1 ! theta* + ztmp2 = Ce/sqrtCd*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) + ztmp0 = MAX( 0.25_wp , UN10_from_CD(zu, Ub, Cd, ppsi=ztmp2) ) ! U_n10 (ztmp2 == psi_m_ncar(zeta_u)) + + IF( ln_cdgw ) THEN ! wave drag case + CdN = MAX( cdn_wave(:,:) + rsmall * ( 1._wp - tmask(:,:,1) ) , 0.1E-3_wp ) + ELSE + CdN = CD_N10_NCAR(ztmp0) ! Cd_n10 + END IF + sqrtCdN10 = SQRT(CdN) + + !! Update of transfer coefficients: + ztmp1 = 1._wp + sqrtCdN10/vkarmn*(LOG(zu/10._wp) - ztmp2) ! L&Y 2004 Eq. (10a) (ztmp2 == psi_m(zeta_u)) + Cd = MAX( CdN / ( ztmp1*ztmp1 ) , 0.1E-3_wp ) + sqrtCd = SQRT( Cd ) + + ztmp0 = ( LOG(zu/10._wp) - psi_h_ncar(zeta_u) ) / vkarmn / sqrtCdN10 + ztmp2 = sqrtCd / sqrtCdN10 + + ztmp1 = 0.5_wp + sign(0.5_wp,zeta_u) ! stability flag + ChN = CH_N10_NCAR( sqrtCdN10 , ztmp1 ) + ztmp1 = 1._wp + ChN*ztmp0 + Ch = MAX( ChN*ztmp2 / ztmp1 , 0.1E-3_wp ) ! L&Y 2004 Eq. (10b) + + CeN = CE_N10_NCAR( sqrtCdN10 ) + ztmp1 = 1._wp + CeN*ztmp0 + Ce = MAX( CeN*ztmp2 / ztmp1 , 0.1E-3_wp ) ! L&Y 2004 Eq. (10c) + + END DO !DO j_itt = 1, nb_itt + + 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 = 1, jpj + DO ji = 1, jpi + ! + 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), 0.1E-3_wp ) + ! + 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 + !!---------------------------------------------------------------------------------- + ! + ch_n10_ncar = MAX( 1.e-3_wp * psqrtcdn10*( 18._wp*pstab + 32.7_wp*(1._wp - pstab) ) , 0.1E-3_wp ) ! 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 ) , 0.1E-3_wp ) + ! + 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) :: zzeta, zx2, zx, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + DO jj = 1, jpj + DO ji = 1, jpi + + zzeta = pzeta(ji,jj) + ! + zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) ) ! (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*zzeta + ! + zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 + ! + psi_m_ncar(ji,jj) = zstab * zpsi_stab & ! (zzeta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zzeta < 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) :: zzeta, zx2, zpsi_unst, zpsi_stab, zstab ! local scalars + !!---------------------------------------------------------------------------------- + ! + DO jj = 1, jpj + DO ji = 1, jpi + ! + zzeta = pzeta(ji,jj) + ! + zx2 = SQRT( ABS(1._wp - 16._wp*zzeta) ) ! (1 -16z)^0.5 + zx2 = MAX( zx2 , 1._wp ) + zpsi_unst = 2._wp*LOG( 0.5_wp*(1._wp + zx2) ) + ! + zpsi_stab = -5._wp*zzeta + ! + zstab = 0.5_wp + SIGN(0.5_wp, zzeta) ! zzeta > 0 => zstab = 1 + ! + psi_h_ncar(ji,jj) = zstab * zpsi_stab & ! (zzeta > 0) Stable + & + (1._wp - zstab) * zpsi_unst ! (zzeta < 0) Unstable + ! + END DO + END DO + END FUNCTION psi_h_ncar + + + + + 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 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 = 1, jpj + DO ji = 1, jpi + ! + 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 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 virt_temp( pta, pqa ) + REAL(wp), DIMENSION(jpi,jpj) :: virt_temp !: 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(:,:) = pta(:,:) * (1._wp + rctv0*pqa(:,:)) + END FUNCTION virt_temp + + !!====================================================================== +END MODULE sbcblk_algo_ncar diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbccpl.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbccpl.F90 new file mode 100644 index 0000000..0a846c9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbccpl.F90 @@ -0,0 +1,2684 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 +#if defined key_si3 + USE ice ! ice variables +#endif + USE cpl_oasis3 ! OASIS3 coupling + USE geo2ocean ! + USE oce , ONLY : tsn, un, vn, sshn, ub, vb, sshb, fraqsr_1lev + USE ocealb ! + USE eosbn2 ! + USE sbcrnf , ONLY : l_rnfcpl + USE sbcisf , ONLY : l_isfcpl +#if defined key_cice + USE ice_domain_size, only: ncat +#endif +#if defined key_si3 + USE icevar ! for CALL ice_var_snwblow +#endif + ! + 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) + +#if defined key_oasis3 + USE mod_oasis, ONLY : OASIS_Sent, OASIS_ToRest, OASIS_SentOut, OASIS_ToRestOut +#endif + + 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 + 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_tauwoc = 50 ! Stress fraction adsorbed by waves + INTEGER, PARAMETER :: jpr_wdrag = 51 ! Neutral surface drag coefficient + INTEGER, PARAMETER :: jpr_isf = 52 + INTEGER, PARAMETER :: jpr_icb = 53 + INTEGER, PARAMETER :: jpr_wfreq = 54 ! Wave peak frequency + INTEGER, PARAMETER :: jpr_tauwx = 55 ! x component of the ocean stress from waves + INTEGER, PARAMETER :: jpr_tauwy = 56 ! y component of the ocean stress from waves + INTEGER, PARAMETER :: jpr_ts_ice = 57 ! Sea ice surface temp + + INTEGER, PARAMETER :: jprcv = 57 ! 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 OPA (by SAS when doing SAS-OPA 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 + +#if ! defined key_oasis3 + ! 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 +#endif + + ! !!** 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_tauw, 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_tauwoc, & + sn_rcv_wdrag, sn_rcv_wfreq + ! ! Other namelist parameters + 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) +#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 + + REAL(wp) :: rpref = 101000._wp ! reference atmospheric pressure[N/m2] + REAL(wp) :: r1_grau ! = 1.e0 / (grav * rau0) + + INTEGER , ALLOCATABLE, SAVE, DIMENSION(:) :: nrcvinfo ! OASIS info argument + + !! Substitution +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_cpl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_cpl_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(5) + !!---------------------------------------------------------------------- + ierr(:) = 0 + ! + ALLOCATE( alb_oce_mix(jpi,jpj), nrcvinfo(jprcv), STAT=ierr(1) ) + +#if ! defined key_si3 && ! defined key_cice + ALLOCATE( a_i(jpi,jpj,1) , STAT=ierr(2) ) ! used in sbcice_if.F90 (done here as there is no sbc_ice_if_init) +#endif + ALLOCATE( xcplmask(jpi,jpj,0:nn_cplmodel) , STAT=ierr(3) ) +#if defined key_si3 || defined key_cice + ALLOCATE( a_i_last_couple(jpi,jpj,jpl) , STAT=ierr(4) ) +#endif + ! + IF( .NOT. ln_apr_dyn ) ALLOCATE( ssh_ib(jpi,jpj), ssh_ibb(jpi,jpj), apr(jpi, jpj), STAT=ierr(5) ) + + 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_tauwoc, & + & sn_rcv_wdrag , sn_rcv_qns , sn_rcv_emp , sn_rcv_rnf , sn_rcv_cal , & + & sn_rcv_iceflx, sn_rcv_co2 , sn_rcv_mslp , & + & sn_rcv_icb , sn_rcv_isf , sn_rcv_wfreq, sn_rcv_tauw , & + & sn_rcv_ts_ice + !!--------------------------------------------------------------------- + ! + ! ================================ ! + ! Namelist informations ! + ! ================================ ! + ! + REWIND( numnam_ref ) ! Namelist namsbc_cpl in reference namelist : Variables for OASIS coupling + READ ( numnam_ref, namsbc_cpl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cpl in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namsbc_cpl in configuration namelist : Variables for OASIS coupling + 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,*)' atm co2 = ', TRIM(sn_rcv_co2%cldes ), ' (', TRIM(sn_rcv_co2%clcat ), ')' + 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,*)' Wave peak frequency = ', TRIM(sn_rcv_wfreq%cldes ), ' (', TRIM(sn_rcv_wfreq%clcat ), ')' + WRITE(numout,*)' Stress frac adsorbed by waves = ', TRIM(sn_rcv_tauwoc%cldes), ' (', TRIM(sn_rcv_tauwoc%clcat ), ')' + WRITE(numout,*)' Stress components by waves = ', TRIM(sn_rcv_tauw%cldes ), ' (', TRIM(sn_rcv_tauw%clcat ), ')' + WRITE(numout,*)' Neutral surf drag coefficient = ', TRIM(sn_rcv_wdrag%cldes ), ' (', TRIM(sn_rcv_wdrag%clcat ), ')' + WRITE(numout,*)' Sea ice surface skin temperature= ', TRIM(sn_rcv_ts_ice%cldes), ' (', TRIM(sn_rcv_ts_ice%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 + + ! ! 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 .AND. ln_isf ) THEN + l_isfcpl = .TRUE. ! -> no need to read isf in sbcisf + 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. + lhftau = srcv(jpr_taum)%laction + ! + ! ! ------------------------- ! + ! ! 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 botmelt ! + ! ! ------------------------- ! + 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 + ! ! ------------------------- ! + ! ! 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 + +#if defined key_si3 + IF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN + IF( .NOT.srcv(jpr_ts_ice)%laction ) & + & CALL ctl_stop( 'sbc_cpl_init: srcv(jpr_ts_ice)%laction should be set to true when ln_cndflx=T' ) + ENDIF +#endif + ! ! ------------------------- ! + ! ! 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_wfreq)%clname = 'O_WFreq' ! wave peak frequency + IF( TRIM(sn_rcv_wfreq%cldes ) == 'coupled' ) THEN + srcv(jpr_wfreq)%laction = .TRUE. + cpl_wfreq = .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_tauwoc)%clname = 'O_TauOce' ! stress fraction adsorbed by the wave + IF( TRIM(sn_rcv_tauwoc%cldes ) == 'coupled' ) THEN + srcv(jpr_tauwoc)%laction = .TRUE. + cpl_tauwoc = .TRUE. + ENDIF + srcv(jpr_tauwx)%clname = 'O_Tauwx' ! ocean stress from wave in the x direction + srcv(jpr_tauwy)%clname = 'O_Tauwy' ! ocean stress from wave in the y direction + IF( TRIM(sn_rcv_tauw%cldes ) == 'coupled' ) THEN + srcv(jpr_tauwx)%laction = .TRUE. + srcv(jpr_tauwy)%laction = .TRUE. + cpl_tauw = .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 + IF( srcv(jpr_tauwoc)%laction .AND. srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction ) & + CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', & + '(sn_rcv_tauwoc=coupled and sn_rcv_tauw=coupled)' ) + ! + ! ! ------------------------------- ! + ! ! OPA-SAS coupling - rcv by opa ! + ! ! ------------------------------- ! + srcv(jpr_sflx)%clname = 'O_SFLX' + srcv(jpr_fice)%clname = 'RIceFrc' + ! + IF( nn_components == jp_iam_opa ) THEN ! OPA coupled to SAS via OASIS: force received field by OPA (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-OPA coupling ' + WRITE(numout,*)' OPA 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 + ! ! -------------------------------- ! + ! ! OPA-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 OPA + ! this is nedeed as each variable name used in the namcouple must be unique: + ! for example O_Runoff received by OPA from SAS and therefore O_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-OPA coupling ' + WRITE(numout,*)' SAS component ' + WRITE(numout,*) + IF( .NOT. ln_cpl ) THEN + WRITE(numout,*)' received fields from OPA component ' + ELSE + WRITE(numout,*)' Additional received fields from OPA 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) ) + END IF + + ! ================================ ! + ! 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 + + ! Initialise ice fractions from last coupling time to zero (needed by Met-Office) +#if defined key_si3 || defined key_cice + a_i_last_couple(:,:,:) = 0._wp +#endif + ! ! ------------------------- ! + ! ! 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. + + ! ! ------------------------------- ! + ! ! OPA-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_opa ) 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 + ! ! ------------------------------- ! + ! ! OPA-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 OPA 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 OPA component ' + ELSE + WRITE(numout,*)' Additional sent fields to OPA 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:nlci,1:nlcj,1:nn_cplmodel), & + & kstart = (/ mig(1),mjg(1),1 /), kcount = (/ nlci,nlcj,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 ) + !!---------------------------------------------------------------------- + !! *** 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) + !! + 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), 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' ) + ncpl_qsr_freq = 86400 / ncpl_qsr_freq ! used by top + ENDIF + ! + IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) + ! + ! ! ======================================================= ! + ! ! Receive all the atmos. fields (including ice information) + ! ! ======================================================= ! + isec = ( kt - nit000 ) * NINT( rdt ) ! 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 = 2, jpjm1 ! T ==> (U,V) + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_multi( 'sbccpl', frcv(jpr_otx1)%z3(:,:,1), 'U', -1., frcv(jpr_oty1)%z3(:,:,1), 'V', -1. ) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vect. opt. + 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. ) + 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 = 1, jpj + DO ji = 1, jpi + 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 * rau0) !* 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) + END IF + ! + 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) + ! + ! ! ========================= ! + ! ! Wave peak frequency ! + ! ! ========================= ! + IF( srcv(jpr_wfreq)%laction ) wfreq(:,:) = frcv(jpr_wfreq)%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 .OR. srcv(jpr_wfreq)%laction) THEN + CALL sbc_stokes() + ENDIF + ENDIF + ! ! ========================= ! + ! ! Stress adsorbed by waves ! + ! ! ========================= ! + IF( srcv(jpr_tauwoc)%laction .AND. ln_tauwoc ) tauoc_wave(:,:) = frcv(jpr_tauwoc)%z3(:,:,1) + + ! ! ========================= ! + ! ! Stress component by waves ! + ! ! ========================= ! + IF( srcv(jpr_tauwx)%laction .AND. srcv(jpr_tauwy)%laction .AND. ln_tauw ) THEN + tauw_x(:,:) = frcv(jpr_tauwx)%z3(:,:,1) + tauw_y(:,:) = frcv(jpr_tauwy)%z3(:,:,1) + ENDIF + + ! ! ========================= ! + ! ! Wave drag coefficient ! + ! ! ========================= ! + IF( srcv(jpr_wdrag)%laction .AND. ln_cdgw ) cdn_wave(:,:) = frcv(jpr_wdrag)%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) + ub (:,:,1) = ssu_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + un (:,:,1) = 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) + vb (:,:,1) = ssv_m(:,:) ! will be used in icestp in the call of ice_forcing_tau + vn (:,:,1) = 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 + IF( srcv(jpr_isf)%laction ) fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) + + 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 + END IF + ! update qns over the free ocean with: + IF( nn_components /= jp_iam_opa ) 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(out), DIMENSION(:,:) :: p_taui ! i- & j-components of atmos-ice stress [N/m2] + REAL(wp), INTENT(out), 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 + !!---------------------------------------------------------------------- + ! + IF( srcv(jpr_itx1)%laction ) THEN ; itx = jpr_itx1 + ELSE ; itx = jpr_otx1 + ENDIF + + ! do something only if we just received the stress from atmosphere + IF( nrcvinfo(itx) == OASIS_Rcv ) THEN + ! ! ======================= ! + IF( srcv(jpr_itx1)%laction ) THEN ! ice stress received ! + ! ! ======================= ! + ! + IF( TRIM( sn_rcv_tau%clvref ) == 'cartesian' ) THEN ! 2 components on the sphere + ! ! (cartesian to spherical -> 3 to 2 components) + CALL geo2oce( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), frcv(jpr_itz1)%z3(:,:,1), & + & srcv(jpr_itx1)%clgrid, ztx, zty ) + frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 1st grid + frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd comp. on the 1st grid + ! + IF( srcv(jpr_itx2)%laction ) THEN + CALL geo2oce( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), frcv(jpr_itz2)%z3(:,:,1), & + & srcv(jpr_itx2)%clgrid, ztx, zty ) + frcv(jpr_itx2)%z3(:,:,1) = ztx(:,:) ! overwrite 1st comp. on the 2nd grid + frcv(jpr_ity2)%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_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->i', ztx ) + IF( srcv(jpr_itx2)%laction ) THEN + CALL rot_rep( frcv(jpr_itx2)%z3(:,:,1), frcv(jpr_ity2)%z3(:,:,1), srcv(jpr_itx2)%clgrid, 'en->j', zty ) + ELSE + CALL rot_rep( frcv(jpr_itx1)%z3(:,:,1), frcv(jpr_ity1)%z3(:,:,1), srcv(jpr_itx1)%clgrid, 'en->j', zty ) + ENDIF + frcv(jpr_itx1)%z3(:,:,1) = ztx(:,:) ! overwrite 1st component on the 1st grid + frcv(jpr_ity1)%z3(:,:,1) = zty(:,:) ! overwrite 2nd component on the 1st grid + ENDIF + ! ! ======================= ! + ELSE ! use ocean stress ! + ! ! ======================= ! + frcv(jpr_itx1)%z3(:,:,1) = frcv(jpr_otx1)%z3(:,:,1) + frcv(jpr_ity1)%z3(:,:,1) = frcv(jpr_oty1)%z3(:,:,1) + ! + ENDIF + ! ! ======================= ! + ! ! put on ice grid ! + ! ! ======================= ! + ! + ! j+1 j -----V---F + ! ice stress on ice velocity point ! | + ! (C-grid ==>(U,V)) j | T U + ! | | + ! j j-1 -I-------| + ! (for I) | | + ! i-1 i i + ! i i+1 (for I) + SELECT CASE ( srcv(jpr_itx1)%clgrid ) + CASE( 'U' ) + p_taui(:,:) = frcv(jpr_itx1)%z3(:,:,1) ! (U,V) ==> (U,V) + p_tauj(:,:) = frcv(jpr_ity1)%z3(:,:,1) + CASE( 'T' ) + DO jj = 2, jpjm1 ! T ==> (U,V) + DO ji = fs_2, fs_jpim1 ! vector opt. + ! take care of the land-sea mask to avoid "pollution" of coastal stress. p[uv]taui used in frazil and rheology + zztmp1 = 0.5_wp * ( 2. - umask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji+1,jj ,1) ) + zztmp2 = 0.5_wp * ( 2. - vmask(ji,jj,1) ) * MAX( tmask(ji,jj,1),tmask(ji ,jj+1,1) ) + p_taui(ji,jj) = zztmp1 * ( frcv(jpr_itx1)%z3(ji+1,jj ,1) + frcv(jpr_itx1)%z3(ji,jj,1) ) + p_tauj(ji,jj) = zztmp2 * ( frcv(jpr_ity1)%z3(ji ,jj+1,1) + frcv(jpr_ity1)%z3(ji,jj,1) ) + END DO + END DO + CALL lbc_lnk_multi( 'sbccpl', p_taui, 'U', -1., p_tauj, 'V', -1. ) + END SELECT + + ENDIF + ! + END SUBROUTINE sbc_cpl_ice_tau + + + SUBROUTINE sbc_cpl_ice_flx( 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 + !! ** 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 + !!---------------------------------------------------------------------- + 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 + !!---------------------------------------------------------------------- + ! + IF( ln_mixcpl ) zmsk(:,:) = 1. - xcplmask(:,:,0) + ziceld(:,:) = 1._wp - picefr(:,:) + zcptn (:,:) = rcp * sst_m(:,:) + ! + ! ! ========================= ! + ! ! freshwater budget ! (emp_tot) + ! ! ========================= ! + ! + ! ! solid Precipitation (sprecip) + ! ! liquid + solid Precipitation (tprecip) + ! ! total Evaporation - total Precipitation (emp_tot) + ! ! sublimation - solid precipitation (cell average) (emp_ice) + SELECT CASE( TRIM( sn_rcv_emp%cldes ) ) + CASE( 'conservative' ) ! received fields: jpr_rain, jpr_snow, jpr_ievp, jpr_tevp + zsprecip(:,:) = frcv(jpr_snow)%z3(:,:,1) ! May need to ensure positive here + ztprecip(:,:) = frcv(jpr_rain)%z3(:,:,1) + zsprecip(:,:) ! May need to ensure positive here + zemp_tot(:,:) = frcv(jpr_tevp)%z3(:,:,1) - ztprecip(:,:) + CASE( 'oce and ice' ) ! received fields: jpr_sbpr, jpr_semp, jpr_oemp, jpr_ievp + zemp_tot(:,:) = ziceld(:,:) * frcv(jpr_oemp)%z3(:,:,1) + picefr(:,:) * frcv(jpr_sbpr)%z3(:,:,1) + zemp_ice(:,:) = frcv(jpr_semp)%z3(:,:,1) * picefr(:,:) + zsprecip(:,:) = frcv(jpr_ievp)%z3(:,:,1) - frcv(jpr_semp)%z3(:,:,1) + ztprecip(:,:) = frcv(jpr_semp)%z3(:,:,1) - frcv(jpr_sbpr)%z3(:,:,1) + zsprecip(:,:) + CASE( 'none' ) ! Not available as for now: needs additional coding below when computing zevap_oce + ! ! since fields received are not defined with none option + CALL ctl_stop( 'STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_emp value in namelist namsbc_cpl' ) + END SELECT + +#if defined key_si3 + + ! --- evaporation over ice (kg/m2/s) --- ! + IF (ln_scale_ice_flux) THEN ! typically met-office requirements + IF (sn_rcv_emp%clcat == 'yes') THEN + WHERE( a_i(:,:,:) > 1.e-10 ) ; zevap_ice(:,:,:) = frcv(jpr_ievp)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + ELSEWHERE ; zevap_ice(:,:,:) = 0._wp + END WHERE + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice_total(:,:) = 0._wp + END WHERE + ELSE + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) * SUM( a_i_last_couple, dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice(:,:,1) = 0._wp + END WHERE + zevap_ice_total(:,:) = zevap_ice(:,:,1) + DO jl = 2, jpl + zevap_ice(:,:,jl) = zevap_ice(:,:,1) + ENDDO + ENDIF + ELSE + IF (sn_rcv_emp%clcat == 'yes') THEN + zevap_ice(:,:,1:jpl) = frcv(jpr_ievp)%z3(:,:,1:jpl) + WHERE( picefr(:,:) > 1.e-10 ) ; zevap_ice_total(:,:) = SUM( zevap_ice(:,:,:) * a_i(:,:,:), dim=3 ) / picefr(:,:) + ELSEWHERE ; zevap_ice_total(:,:) = 0._wp + END WHERE + ELSE + zevap_ice(:,:,1) = frcv(jpr_ievp)%z3(:,:,1) + zevap_ice_total(:,:) = zevap_ice(:,:,1) + DO jl = 2, jpl + zevap_ice(:,:,jl) = zevap_ice(:,:,1) + ENDDO + ENDIF + ENDIF + + IF ( TRIM( sn_rcv_emp%cldes ) == 'conservative' ) THEN + ! For conservative case zemp_ice has not been defined yet. Do it now. + zemp_ice(:,:) = zevap_ice_total(:,:) * picefr(:,:) - frcv(jpr_snow)%z3(:,:,1) * picefr(:,:) + ENDIF + + ! zsnw = snow fraction over ice after wind blowing (=picefr if no blowing) + zsnw(:,:) = 0._wp ; CALL ice_var_snwblow( ziceld, zsnw ) + + ! --- evaporation minus precipitation corrected (because of wind blowing on snow) --- ! + zemp_ice(:,:) = zemp_ice(:,:) + zsprecip(:,:) * ( picefr(:,:) - zsnw(:,:) ) ! emp_ice = A * sublimation - zsnw * sprecip + zemp_oce(:,:) = zemp_tot(:,:) - zemp_ice(:,:) ! emp_oce = emp_tot - emp_ice + + ! --- evaporation over ocean (used later for qemp) --- ! + zevap_oce(:,:) = frcv(jpr_tevp)%z3(:,:,1) - zevap_ice_total(:,:) * picefr(:,:) + + ! since the sensitivity of evap to temperature (devap/dT) is not prescribed by the atmosphere, we set it to 0 + ! therefore, sublimation is not redistributed over the ice categories when no subgrid scale fluxes are provided by atm. + zdevap_ice(:,:) = 0._wp + + ! --- Continental fluxes --- ! + IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) + rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + ENDIF + IF( srcv(jpr_cal)%laction ) THEN ! calving (put in emp_tot and emp_oce) + zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) + zemp_oce(:,:) = zemp_oce(:,:) - frcv(jpr_cal)%z3(:,:,1) + ENDIF + IF( srcv(jpr_icb)%laction ) THEN ! iceberg added to runoffs + fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) + rnf(:,:) = rnf(:,:) + fwficb(:,:) + ENDIF + IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf <0 mean melting) + fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) + ENDIF + + IF( ln_mixcpl ) THEN + emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) + emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) + emp_oce(:,:) = emp_oce(:,:) * xcplmask(:,:,0) + zemp_oce(:,:) * zmsk(:,:) + sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) + tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) + DO jl = 1, jpl + evap_ice (:,:,jl) = evap_ice (:,:,jl) * xcplmask(:,:,0) + zevap_ice (:,:,jl) * zmsk(:,:) + devap_ice(:,:,jl) = devap_ice(:,:,jl) * xcplmask(:,:,0) + zdevap_ice(:,:) * zmsk(:,:) + END DO + ELSE + emp_tot (:,:) = zemp_tot (:,:) + emp_ice (:,:) = zemp_ice (:,:) + emp_oce (:,:) = zemp_oce (:,:) + sprecip (:,:) = zsprecip (:,:) + tprecip (:,:) = ztprecip (:,:) + evap_ice(:,:,:) = zevap_ice(:,:,:) + DO jl = 1, jpl + devap_ice(:,:,jl) = zdevap_ice(:,:) + END DO + ENDIF + +#else + zsnw(:,:) = picefr(:,:) + ! --- Continental fluxes --- ! + IF( srcv(jpr_rnf)%laction ) THEN ! runoffs (included in emp later on) + rnf(:,:) = frcv(jpr_rnf)%z3(:,:,1) + ENDIF + IF( srcv(jpr_cal)%laction ) THEN ! calving (put in emp_tot) + zemp_tot(:,:) = zemp_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) + ENDIF + IF( srcv(jpr_icb)%laction ) THEN ! iceberg added to runoffs + fwficb(:,:) = frcv(jpr_icb)%z3(:,:,1) + rnf(:,:) = rnf(:,:) + fwficb(:,:) + ENDIF + IF( srcv(jpr_isf)%laction ) THEN ! iceshelf (fwfisf <0 mean melting) + fwfisf(:,:) = - frcv(jpr_isf)%z3(:,:,1) + ENDIF + ! + IF( ln_mixcpl ) THEN + emp_tot(:,:) = emp_tot(:,:) * xcplmask(:,:,0) + zemp_tot(:,:) * zmsk(:,:) + emp_ice(:,:) = emp_ice(:,:) * xcplmask(:,:,0) + zemp_ice(:,:) * zmsk(:,:) + sprecip(:,:) = sprecip(:,:) * xcplmask(:,:,0) + zsprecip(:,:) * zmsk(:,:) + tprecip(:,:) = tprecip(:,:) * xcplmask(:,:,0) + ztprecip(:,:) * zmsk(:,:) + ELSE + emp_tot(:,:) = zemp_tot(:,:) + emp_ice(:,:) = zemp_ice(:,:) + sprecip(:,:) = zsprecip(:,:) + tprecip(:,:) = ztprecip(:,:) + ENDIF + ! +#endif + + ! outputs +!! IF( srcv(jpr_rnf)%laction ) CALL iom_put( 'runoffs' , rnf(:,:) * tmask(:,:,1) ) ! runoff +!! IF( srcv(jpr_isf)%laction ) CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) * tmask(:,:,1) ) ! iceshelf + IF( srcv(jpr_cal)%laction ) CALL iom_put( 'calving_cea' , frcv(jpr_cal)%z3(:,:,1) * tmask(:,:,1) ) ! calving + IF( srcv(jpr_icb)%laction ) CALL iom_put( 'iceberg_cea' , frcv(jpr_icb)%z3(:,:,1) * tmask(:,:,1) ) ! icebergs + IF( iom_use('snowpre') ) CALL iom_put( 'snowpre' , sprecip(:,:) ) ! Snow + IF( iom_use('precip') ) CALL iom_put( 'precip' , tprecip(:,:) ) ! total precipitation + IF( iom_use('rain') ) CALL iom_put( 'rain' , tprecip(:,:) - sprecip(:,:) ) ! liquid precipitation + IF( iom_use('snow_ao_cea') ) CALL iom_put( 'snow_ao_cea' , sprecip(:,:) * ( 1._wp - zsnw(:,:) ) ) ! Snow over ice-free ocean (cell average) + IF( iom_use('snow_ai_cea') ) CALL iom_put( 'snow_ai_cea' , sprecip(:,:) * zsnw(:,:) ) ! Snow over sea-ice (cell average) + IF( iom_use('rain_ao_cea') ) CALL iom_put( 'rain_ao_cea' , ( tprecip(:,:) - sprecip(:,:) ) * picefr(:,:) ) ! liquid precipitation over ocean (cell average) + IF( iom_use('subl_ai_cea') ) CALL iom_put( 'subl_ai_cea' , frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * tmask(:,:,1) ) ! Sublimation over sea-ice (cell average) + IF( iom_use('evap_ao_cea') ) CALL iom_put( 'evap_ao_cea' , ( frcv(jpr_tevp)%z3(:,:,1) & + & - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) * tmask(:,:,1) ) ! ice-free oce evap (cell average) + ! note: runoff output is done in sbcrnf (which includes icebergs too) and iceshelf output is done in sbcisf + ! + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_qns%cldes ) ) ! non solar heat fluxes ! (qns) + ! ! ========================= ! + CASE( 'oce only' ) ! the required field is directly provided + zqns_tot(:,:) = frcv(jpr_qnsoce)%z3(:,:,1) + ! For Met Office sea ice non-solar fluxes are already delt with by JULES so setting to zero + ! here so the only flux is the ocean only one. + zqns_ice(:,:,:) = 0._wp + CASE( 'conservative' ) ! the required fields are directly provided + zqns_tot(:,:) = frcv(jpr_qnsmix)%z3(:,:,1) + IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN + zqns_ice(:,:,1:jpl) = frcv(jpr_qnsice)%z3(:,:,1:jpl) + ELSE + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) ! Set all category values equal + END DO + ENDIF + CASE( 'oce and ice' ) ! the total flux is computed from ocean and ice fluxes + zqns_tot(:,:) = ziceld(:,:) * frcv(jpr_qnsoce)%z3(:,:,1) + IF ( TRIM(sn_rcv_qns%clcat) == 'yes' ) THEN + DO jl=1,jpl + zqns_tot(:,: ) = zqns_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qnsice)%z3(:,:,jl) + zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,jl) + ENDDO + ELSE + zqns_tot(:,:) = zqns_tot(:,:) + picefr(:,:) * frcv(jpr_qnsice)%z3(:,:,1) + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsice)%z3(:,:,1) + END DO + ENDIF + CASE( 'mixed oce-ice' ) ! the ice flux is cumputed from the total flux, the SST and ice informations +! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** + zqns_tot(:,: ) = frcv(jpr_qnsmix)%z3(:,:,1) + IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:,jl) & + & + frcv(jpr_dqnsdt)%z3(:,:,jl) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & + & + pist(:,:,jl) * picefr(:,:) ) ) + END DO + ELSE + DO jl = 1, jpl + zqns_ice(:,:,jl) = frcv(jpr_qnsmix)%z3(:,:, 1) & + & + frcv(jpr_dqnsdt)%z3(:,:, 1) * ( pist(:,:,jl) - ( ( rt0 + psst(:,:) ) * ziceld(:,:) & + & + pist(:,:,jl) * picefr(:,:) ) ) + END DO + ENDIF + END SELECT + ! + ! --- calving (removed from qns_tot) --- ! + IF( srcv(jpr_cal)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_cal)%z3(:,:,1) * rLfus ! remove latent heat of calving + ! we suppose it melts at 0deg, though it should be temp. of surrounding ocean + ! --- iceberg (removed from qns_tot) --- ! + IF( srcv(jpr_icb)%laction ) zqns_tot(:,:) = zqns_tot(:,:) - frcv(jpr_icb)%z3(:,:,1) * rLfus ! remove latent heat of iceberg melting + +#if defined key_si3 + ! --- non solar flux over ocean --- ! + ! note: ziceld cannot be = 0 since we limit the ice concentration to amax + zqns_oce = 0._wp + WHERE( ziceld /= 0._wp ) zqns_oce(:,:) = ( zqns_tot(:,:) - SUM( a_i * zqns_ice, dim=3 ) ) / ziceld(:,:) + + ! Heat content per unit mass of snow (J/kg) + WHERE( SUM( a_i, dim=3 ) > 1.e-10 ) ; zcptsnw(:,:) = rcpi * SUM( (tn_ice - rt0) * a_i, dim=3 ) / SUM( a_i, dim=3 ) + ELSEWHERE ; zcptsnw(:,:) = zcptn(:,:) + ENDWHERE + ! Heat content per unit mass of rain (J/kg) + zcptrain(:,:) = rcp * ( SUM( (tn_ice(:,:,:) - rt0) * a_i(:,:,:), dim=3 ) + sst_m(:,:) * ziceld(:,:) ) + + ! --- enthalpy of snow precip over ice in J/m3 (to be used in 1D-thermo) --- ! + zqprec_ice(:,:) = rhos * ( zcptsnw(:,:) - rLfus ) + + ! --- heat content of evap over ice in W/m2 (to be used in 1D-thermo) --- ! + DO jl = 1, jpl + zqevap_ice(:,:,jl) = 0._wp ! should be -evap * ( ( Tice - rt0 ) * rcpi ) but atm. does not take it into account + END DO + + ! --- heat flux associated with emp (W/m2) --- ! + zqemp_oce(:,:) = - zevap_oce(:,:) * zcptn (:,:) & ! evap + & + ( ztprecip(:,:) - zsprecip(:,:) ) * zcptrain(:,:) & ! liquid precip + & + zsprecip(:,:) * ( 1._wp - zsnw ) * ( zcptsnw (:,:) - rLfus ) ! solid precip over ocean + snow melting + zqemp_ice(:,:) = zsprecip(:,:) * zsnw * ( zcptsnw (:,:) - rLfus ) ! solid precip over ice (qevap_ice=0 since atm. does not take it into account) +!! zqemp_ice(:,:) = - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) * zcptsnw (:,:) & ! ice evap +!! & + zsprecip(:,:) * zsnw * zqprec_ice(:,:) * r1_rhos ! solid precip over ice + + ! --- total non solar flux (including evap/precip) --- ! + zqns_tot(:,:) = zqns_tot(:,:) + zqemp_ice(:,:) + zqemp_oce(:,:) + + ! --- in case both coupled/forced are active, we must mix values --- ! + IF( ln_mixcpl ) THEN + qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) + qns_oce(:,:) = qns_oce(:,:) * xcplmask(:,:,0) + zqns_oce(:,:)* zmsk(:,:) + DO jl=1,jpl + qns_ice (:,:,jl) = qns_ice (:,:,jl) * xcplmask(:,:,0) + zqns_ice (:,:,jl)* zmsk(:,:) + qevap_ice(:,:,jl) = qevap_ice(:,:,jl) * xcplmask(:,:,0) + zqevap_ice(:,:,jl)* zmsk(:,:) + ENDDO + qprec_ice(:,:) = qprec_ice(:,:) * xcplmask(:,:,0) + zqprec_ice(:,:)* zmsk(:,:) + qemp_oce (:,:) = qemp_oce(:,:) * xcplmask(:,:,0) + zqemp_oce(:,:)* zmsk(:,:) + qemp_ice (:,:) = qemp_ice(:,:) * xcplmask(:,:,0) + zqemp_ice(:,:)* zmsk(:,:) + ELSE + qns_tot (:,: ) = zqns_tot (:,: ) + qns_oce (:,: ) = zqns_oce (:,: ) + qns_ice (:,:,:) = zqns_ice (:,:,:) + qevap_ice(:,:,:) = zqevap_ice(:,:,:) + qprec_ice(:,: ) = zqprec_ice(:,: ) + qemp_oce (:,: ) = zqemp_oce (:,: ) + qemp_ice (:,: ) = zqemp_ice (:,: ) + ENDIF + +#else + zcptsnw (:,:) = zcptn(:,:) + zcptrain(:,:) = zcptn(:,:) + + ! clem: this formulation is certainly wrong... but better than it was... + zqns_tot(:,:) = zqns_tot(:,:) & ! zqns_tot update over free ocean with: + & - ( ziceld(:,:) * zsprecip(:,:) * rLfus ) & ! remove the latent heat flux of solid precip. melting + & - ( zemp_tot(:,:) & ! remove the heat content of mass flux (assumed to be at SST) + & - zemp_ice(:,:) ) * zcptn(:,:) + + IF( ln_mixcpl ) THEN + qns_tot(:,:) = qns(:,:) * ziceld(:,:) + SUM( qns_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk + qns_tot(:,:) = qns_tot(:,:) * xcplmask(:,:,0) + zqns_tot(:,:)* zmsk(:,:) + DO jl=1,jpl + qns_ice(:,:,jl) = qns_ice(:,:,jl) * xcplmask(:,:,0) + zqns_ice(:,:,jl)* zmsk(:,:) + ENDDO + ELSE + qns_tot(:,: ) = zqns_tot(:,: ) + qns_ice(:,:,:) = zqns_ice(:,:,:) + ENDIF + +#endif + ! outputs + IF ( srcv(jpr_cal)%laction ) CALL iom_put('hflx_cal_cea' , - frcv(jpr_cal)%z3(:,:,1) * rLfus ) ! latent heat from calving + IF ( srcv(jpr_icb)%laction ) CALL iom_put('hflx_icb_cea' , - frcv(jpr_icb)%z3(:,:,1) * rLfus ) ! latent heat from icebergs melting + IF ( iom_use( 'hflx_rain_cea') ) CALL iom_put('hflx_rain_cea' , ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) ! heat flux from rain (cell average) + IF ( iom_use( 'hflx_evap_cea') ) CALL iom_put('hflx_evap_cea' , ( frcv(jpr_tevp)%z3(:,:,1) - frcv(jpr_ievp)%z3(:,:,1) * picefr(:,:) ) & + & * zcptn(:,:) * tmask(:,:,1) ) ! heat flux from evap (cell average) + IF ( iom_use( 'hflx_prec_cea') ) CALL iom_put('hflx_prec_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) & ! heat flux from all precip (cell avg) + & + ( tprecip(:,:) - sprecip(:,:) ) * zcptrain(:,:) ) + IF ( iom_use( 'hflx_snow_cea') ) CALL iom_put('hflx_snow_cea' , sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) ) ! heat flux from snow (cell average) + IF ( iom_use('hflx_snow_ao_cea') ) CALL iom_put('hflx_snow_ao_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * ( 1._wp - zsnw(:,:) ) ) ! heat flux from snow (over ocean) + IF ( iom_use('hflx_snow_ai_cea') ) CALL iom_put('hflx_snow_ai_cea', sprecip(:,:) * ( zcptsnw(:,:) - rLfus ) * zsnw(:,:) ) ! heat flux from snow (over ice) + ! note: hflx for runoff and iceshelf are done in sbcrnf and sbcisf resp. + ! + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_qsr%cldes ) ) ! solar heat fluxes ! (qsr) + ! ! ========================= ! + CASE( 'oce only' ) + zqsr_tot(:,: ) = MAX( 0._wp , frcv(jpr_qsroce)%z3(:,:,1) ) + ! For Met Office sea ice solar fluxes are already delt with by JULES so setting to zero + ! here so the only flux is the ocean only one. + zqsr_ice(:,:,:) = 0._wp + CASE( 'conservative' ) + zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) + IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + zqsr_ice(:,:,1:jpl) = frcv(jpr_qsrice)%z3(:,:,1:jpl) + ELSE + ! Set all category values equal for the moment + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) + END DO + ENDIF + CASE( 'oce and ice' ) + zqsr_tot(:,: ) = ziceld(:,:) * frcv(jpr_qsroce)%z3(:,:,1) + IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + DO jl = 1, jpl + zqsr_tot(:,: ) = zqsr_tot(:,:) + a_i(:,:,jl) * frcv(jpr_qsrice)%z3(:,:,jl) + zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,jl) + END DO + ELSE + zqsr_tot(:,:) = zqsr_tot(:,:) + picefr(:,:) * frcv(jpr_qsrice)%z3(:,:,1) + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrice)%z3(:,:,1) + END DO + ENDIF + CASE( 'mixed oce-ice' ) + zqsr_tot(:,: ) = frcv(jpr_qsrmix)%z3(:,:,1) +! ** NEED TO SORT OUT HOW THIS SHOULD WORK IN THE MULTI-CATEGORY CASE - CURRENTLY NOT ALLOWED WHEN INTERFACE INITIALISED ** +! Create solar heat flux over ice using incoming solar heat flux and albedos +! ( see OASIS3 user guide, 5th edition, p39 ) + IF ( TRIM(sn_rcv_qsr%clcat) == 'yes' ) THEN + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:,jl) * ( 1.- palbi(:,:,jl) ) & + & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & + & + palbi (:,:,jl) * picefr(:,:) ) ) + END DO + ELSE + DO jl = 1, jpl + zqsr_ice(:,:,jl) = frcv(jpr_qsrmix)%z3(:,:, 1) * ( 1.- palbi(:,:,jl) ) & + & / ( 1.- ( alb_oce_mix(:,: ) * ziceld(:,:) & + & + palbi (:,:,jl) * picefr(:,:) ) ) + END DO + ENDIF + CASE( 'none' ) ! Not available as for now: needs additional coding + ! ! since fields received, here zqsr_tot, are not defined with none option + CALL ctl_stop( 'STOP', 'sbccpl/sbc_cpl_ice_flx: some fields are not defined. Change sn_rcv_qsr value in namelist namsbc_cpl' ) + END SELECT + IF( ln_dm2dc .AND. ln_cpl ) THEN ! modify qsr to include the diurnal cycle + zqsr_tot(:,: ) = sbc_dcy( zqsr_tot(:,: ) ) + DO jl = 1, jpl + zqsr_ice(:,:,jl) = sbc_dcy( zqsr_ice(:,:,jl) ) + END DO + ENDIF + +#if defined key_si3 + ! --- solar flux over ocean --- ! + ! note: ziceld cannot be = 0 since we limit the ice concentration to amax + zqsr_oce = 0._wp + WHERE( ziceld /= 0._wp ) zqsr_oce(:,:) = ( zqsr_tot(:,:) - SUM( a_i * zqsr_ice, dim=3 ) ) / ziceld(:,:) + + IF( ln_mixcpl ) THEN ; qsr_oce(:,:) = qsr_oce(:,:) * xcplmask(:,:,0) + zqsr_oce(:,:)* zmsk(:,:) + ELSE ; qsr_oce(:,:) = zqsr_oce(:,:) ; ENDIF +#endif + + IF( ln_mixcpl ) THEN + qsr_tot(:,:) = qsr(:,:) * ziceld(:,:) + SUM( qsr_ice(:,:,:) * a_i(:,:,:), dim=3 ) ! total flux from blk + qsr_tot(:,:) = qsr_tot(:,:) * xcplmask(:,:,0) + zqsr_tot(:,:)* zmsk(:,:) + DO jl = 1, jpl + qsr_ice(:,:,jl) = qsr_ice(:,:,jl) * xcplmask(:,:,0) + zqsr_ice(:,:,jl)* zmsk(:,:) + END DO + ELSE + qsr_tot(:,: ) = zqsr_tot(:,: ) + qsr_ice(:,:,:) = zqsr_ice(:,:,:) + ENDIF + + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_dqnsdt%cldes ) ) ! d(qns)/dt ! + ! ! ========================= ! + CASE ('coupled') + IF ( TRIM(sn_rcv_dqnsdt%clcat) == 'yes' ) THEN + zdqns_ice(:,:,1:jpl) = frcv(jpr_dqnsdt)%z3(:,:,1:jpl) + ELSE + ! Set all category values equal for the moment + DO jl=1,jpl + zdqns_ice(:,:,jl) = frcv(jpr_dqnsdt)%z3(:,:,1) + ENDDO + ENDIF + CASE( 'none' ) + zdqns_ice(:,:,:) = 0._wp + END SELECT + + IF( ln_mixcpl ) THEN + DO jl=1,jpl + dqns_ice(:,:,jl) = dqns_ice(:,:,jl) * xcplmask(:,:,0) + zdqns_ice(:,:,jl) * zmsk(:,:) + ENDDO + ELSE + dqns_ice(:,:,:) = zdqns_ice(:,:,:) + ENDIF + +#if defined key_si3 + ! ! ========================= ! + SELECT CASE( TRIM( sn_rcv_iceflx%cldes ) ) ! ice topmelt and botmelt ! + ! ! ========================= ! + CASE ('coupled') + IF (ln_scale_ice_flux) THEN + WHERE( a_i(:,:,:) > 1.e-10_wp ) + qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) * a_i_last_couple(:,:,:) / a_i(:,:,:) + ELSEWHERE + qml_ice(:,:,:) = 0.0_wp + qcn_ice(:,:,:) = 0.0_wp + END WHERE + ELSE + qml_ice(:,:,:) = frcv(jpr_topm)%z3(:,:,:) + qcn_ice(:,:,:) = frcv(jpr_botm)%z3(:,:,:) + ENDIF + END SELECT + ! ! ========================= ! + ! ! Transmitted Qsr ! [W/m2] + ! ! ========================= ! + IF( .NOT.ln_cndflx ) THEN !== No conduction flux as surface forcing ==! + ! + IF( nn_qtrice == 0 ) THEN + ! formulation derived from Grenfell and Maykut (1977), where transmission rate + ! 1) depends on cloudiness + ! ! ===> used prescribed cloud fraction representative for polar oceans in summer (0.81) + ! ! should be real cloud fraction instead (as in the bulk) but needs to be read from atm. + ! 2) is 0 when there is any snow + ! 3) tends to 1 for thin ice + ztri(:,:) = 0.18 * ( 1.0 - cloud_fra(:,:) ) + 0.35 * cloud_fra(:,:) ! surface transmission when hi>10cm + DO jl = 1, jpl + WHERE ( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) < 0.1_wp ) ! linear decrease from hi=0 to 10cm + zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ( ztri(:,:) + ( 1._wp - ztri(:,:) ) * ( 1._wp - phi(:,:,jl) * 10._wp ) ) + ELSEWHERE( phs(:,:,jl) <= 0._wp .AND. phi(:,:,jl) >= 0.1_wp ) ! constant (ztri) when hi>10cm + zqtr_ice_top(:,:,jl) = zqsr_ice(:,:,jl) * ztri(:,:) + ELSEWHERE ! zero when hs>0 + zqtr_ice_top(:,:,jl) = 0._wp + END WHERE + ENDDO + ELSEIF( nn_qtrice == 1 ) THEN + ! formulation is derived from the thesis of M. Lebrun (2019). + ! It represents the best fit using several sets of observations + ! It comes with snow conductivities adapted to freezing/melting conditions (see icethd_zdf_bl99.F90) + zqtr_ice_top(:,:,:) = 0.3_wp * zqsr_ice(:,:,:) + ENDIF + ! + ELSEIF( ln_cndflx .AND. .NOT.ln_cndemulate ) THEN !== conduction flux as surface forcing ==! + ! + ! ! ===> here we must receive the qtr_ice_top array from the coupler + ! for now just assume zero (fully opaque ice) + zqtr_ice_top(:,:,:) = 0._wp + ! + ENDIF + ! + IF( ln_mixcpl ) THEN + DO jl=1,jpl + qtr_ice_top(:,:,jl) = qtr_ice_top(:,:,jl) * xcplmask(:,:,0) + zqtr_ice_top(:,:,jl) * zmsk(:,:) + ENDDO + ELSE + qtr_ice_top(:,:,:) = zqtr_ice_top(:,:,:) + ENDIF + ! ! ================== ! + ! ! ice skin temp. ! + ! ! ================== ! + ! needed by Met Office + IF( srcv(jpr_ts_ice)%laction ) THEN + WHERE ( frcv(jpr_ts_ice)%z3(:,:,:) > 0.0 ) ; ztsu(:,:,:) = 0. + rt0 + ELSEWHERE( frcv(jpr_ts_ice)%z3(:,:,:) < -60. ) ; ztsu(:,:,:) = -60. + rt0 + ELSEWHERE ; ztsu(:,:,:) = frcv(jpr_ts_ice)%z3(:,:,:) + rt0 + END WHERE + ! + IF( ln_mixcpl ) THEN + DO jl=1,jpl + pist(:,:,jl) = pist(:,:,jl) * xcplmask(:,:,0) + ztsu(:,:,jl) * zmsk(:,:) + ENDDO + ELSE + pist(:,:,:) = ztsu(:,:,:) + ENDIF + ! + ENDIF + ! +#endif + ! + END SUBROUTINE sbc_cpl_ice_flx + + + SUBROUTINE sbc_cpl_snd( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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( rdt ) ! 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_opa ) THEN + ztmp1(:,:) = tsn(:,:,1,jp_tem) ! 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( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) + ELSE ; ztmp1(:,:) = tsn(:,:,1,jp_tem) + 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(:,:) = tsn(:,:,1,jp_tem) + 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. ! + ! ! ------------------------- ! +#if defined key_si3 + ! needed by Met Office + IF( ssnd(jps_ttilyr)%laction) THEN + SELECT CASE( sn_snd_ttilyr%cldes) + CASE ('weighted ice') + ztmp3(:,:,1:jpl) = t1_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_ttilyr%cldes' ) + END SELECT + IF( ssnd(jps_ttilyr)%laction ) CALL cpl_snd( jps_ttilyr, isec, ztmp3, info ) + ENDIF +#endif + ! ! ------------------------- ! + ! ! 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 defined key_si3 || defined key_cice + ! If this coupling was successful then save ice fraction for use between coupling points. + ! This is needed for some calculations where the ice fraction at the last coupling point + ! is needed. + IF( info == OASIS_Sent .OR. info == OASIS_ToRest .OR. & + & info == OASIS_SentOut .OR. info == OASIS_ToRestOut ) THEN + IF ( sn_snd_thick%clcat == 'yes' ) THEN + a_i_last_couple(:,:,1:jpl) = a_i(:,:,1:jpl) + ENDIF + ENDIF +#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 OPA (sent by SAS in SAS-OPA 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 + +#if defined key_si3 + ! ! ------------------------- ! + ! ! Ice melt ponds ! + ! ! ------------------------- ! + ! needed by Met Office: 1) fraction of ponded ice 2) local/actual pond depth + IF( ssnd(jps_a_p)%laction .OR. ssnd(jps_ht_p)%laction ) THEN + SELECT CASE( sn_snd_mpnd%cldes) + CASE( 'ice only' ) + SELECT CASE( sn_snd_mpnd%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = a_ip_eff(:,:,1:jpl) + ztmp4(:,:,1:jpl) = h_ip(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + ztmp4(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + a_ip_frac(:,:,jpl) + ztmp4(:,:,1) = ztmp4(:,:,1) + h_ip(:,:,jpl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%clcat' ) + END SELECT + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_mpnd%cldes' ) + END SELECT + IF( ssnd(jps_a_p)%laction ) CALL cpl_snd( jps_a_p , isec, ztmp3, info ) + IF( ssnd(jps_ht_p)%laction ) CALL cpl_snd( jps_ht_p, isec, ztmp4, info ) + ENDIF + ! + ! ! ------------------------- ! + ! ! Ice conductivity ! + ! ! ------------------------- ! + ! needed by Met Office + IF( ssnd(jps_kice)%laction ) THEN + SELECT CASE( sn_snd_cond%cldes) + CASE( 'weighted ice' ) + SELECT CASE( sn_snd_cond%clcat ) + CASE( 'yes' ) + ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) * a_i(:,:,1:jpl) + CASE( 'no' ) + ztmp3(:,:,:) = 0.0 + DO jl=1,jpl + ztmp3(:,:,1) = ztmp3(:,:,1) + cnd_ice(:,:,jl) * a_i(:,:,jl) + ENDDO + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%clcat' ) + END SELECT + CASE( 'ice only' ) + ztmp3(:,:,1:jpl) = cnd_ice(:,:,1:jpl) + CASE default ; CALL ctl_stop( 'sbc_cpl_snd: wrong definition of sn_snd_cond%cldes' ) + END SELECT + IF( ssnd(jps_kice)%laction ) CALL cpl_snd( jps_kice, isec, ztmp3, info ) + ENDIF +#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_opa ) THEN + zotx1(:,:) = un(:,:,1) + zoty1(:,:) = vn(:,:,1) + ELSE + SELECT CASE( TRIM( sn_snd_crt%cldes ) ) + CASE( 'oce only' ) ! C-grid ==> T + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) + zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji ,jj-1,1) ) + END DO + END DO + CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) + zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * 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_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. ) + CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) & + & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * 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_multi( 'sbccpl', zotx1, ssnd(jps_ocx1)%clgrid, -1., zoty1, ssnd(jps_ocy1)%clgrid, -1. ) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zotx1(ji,jj) = 0.5 * ( un(ji,jj,1) + un(ji-1,jj ,1) ) + zoty1(ji,jj) = 0.5 * ( vn(ji,jj,1) + vn(ji , jj-1,1) ) + END DO + END DO + CASE( 'weighted oce and ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) + zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * 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_multi( 'sbccpl', zitx1, 'T', -1., zity1, 'T', -1. ) + CASE( 'mixed oce-ice' ) ! Ocean and Ice on C-grid ==> T + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zotx1(ji,jj) = 0.5 * ( un (ji,jj,1) + un (ji-1,jj ,1) ) * zfr_l(ji,jj) & + & + 0.5 * ( u_ice(ji,jj ) + u_ice(ji-1,jj ) ) * fr_i(ji,jj) + zoty1(ji,jj) = 0.5 * ( vn (ji,jj,1) + vn (ji ,jj-1,1) ) * 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_multi( 'sbccpl', zotx1, ssnd(jps_ocxw)%clgrid, -1., zoty1, ssnd(jps_ocyw)%clgrid, -1. ) + ! + ! + 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 ) + END IF + ! ! ------------------------- ! + ! ! Water levels to waves ! + ! ! ------------------------- ! + IF( ssnd(jps_wlev)%laction ) THEN + IF( ln_apr_dyn ) THEN + IF( kt /= nit000 ) THEN + ztmp1(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE + ztmp1(:,:) = sshb(:,:) + ENDIF + ELSE + ztmp1(:,:) = sshn(:,:) + ENDIF + CALL cpl_snd( jps_wlev , isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info ) + END IF + ! + ! Fields sent by OPA to SAS when doing OPA<->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(:,:) = sshb(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ztmp1(:,:) = sshn(:,:) + 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, RESHAPE ( tsn(:,:,1,jp_sal), (/jpi,jpj,1/) ), info ) + ENDIF + ! ! first T level thickness + IF( ssnd(jps_e3t1st )%laction ) THEN + CALL cpl_snd( jps_e3t1st, isec, RESHAPE ( e3t_n(:,:,1) , (/jpi,jpj,1/) ), 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 OPA 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 ) + +#if defined key_si3 + ! ! ------------------------- ! + ! ! Sea surface freezing temp ! + ! ! ------------------------- ! + ! needed by Met Office + CALL eos_fzp(tsn(:,:,1,jp_sal), sstfrz) + ztmp1(:,:) = sstfrz(:,:) + rt0 + IF( ssnd(jps_sstfrz)%laction ) CALL cpl_snd( jps_sstfrz, isec, RESHAPE ( ztmp1, (/jpi,jpj,1/) ), info) +#endif + ! + END SUBROUTINE sbc_cpl_snd + + !!====================================================================== +END MODULE sbccpl diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcdcy.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcdcy.F90 new file mode 100644 index 0000000..1903586 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcdcy.F90 @@ -0,0 +1,248 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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, rdawn, rdusk, rscal ! - - - + + PUBLIC sbc_dcy ! routine called by sbc + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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(jpi,jpj) , rdusk(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) :: ztwopi, zinvtwopi, zconvrad + REAL(wp) :: zlo, zup, zlousd, zupusd + REAL(wp) :: zdsws, zdecrad, ztx, zsin, zcos + REAL(wp) :: ztmp, ztmp1, ztmp2, ztest + REAL(wp) :: ztmpm, ztmpm1, ztmpm2 + !---------------------------statement functions------------------------ + REAL(wp) :: fintegral, pt1, pt2, paaa, pbbb, pccc ! dummy statement function arguments + fintegral( pt1, pt2, paaa, pbbb, pccc ) = & + & paaa * pt2 + zinvtwopi * pbbb * SIN(pccc + ztwopi * pt2) & + & - paaa * pt1 - zinvtwopi * pbbb * SIN(pccc + ztwopi * pt1) + !!--------------------------------------------------------------------- + ! + ! Initialization + ! -------------- + ztwopi = 2._wp * rpi + zinvtwopi = 1._wp / ztwopi + zconvrad = ztwopi / 360._wp + + ! When are we during the day (from 0 to 1) + zlo = ( REAL(nsec_day, wp) - 0.5_wp * rdt ) / rday + zup = zlo + ( REAL(nn_fsbc, wp) * rdt ) / 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 + ! 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(:,:) = zconvrad * 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 * zconvrad) * COS( zdsws * ztwopi / 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 = 1, jpj + DO ji = 1, jpi + ztmp = zconvrad * 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 = 1, jpj + DO ji = 1, jpi + IF ( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h + ! When is it night? + ztx = zinvtwopi * (ACOS(rab(ji,jj)) - rcc(ji,jj)) + ztest = -rbb(ji,jj) * SIN( rcc(ji,jj) + ztwopi * ztx ) + ! is it dawn or dusk? + IF ( ztest > 0._wp ) THEN + rdawn(ji,jj) = ztx + rdusk(ji,jj) = rtmd(ji,jj) + ( rtmd(ji,jj) - rdawn(ji,jj) ) + ELSE + rdusk(ji,jj) = ztx + rdawn(ji,jj) = rtmd(ji,jj) - ( rdusk(ji,jj) - rtmd(ji,jj) ) + ENDIF + ELSE + rdawn(ji,jj) = rtmd(ji,jj) + 0.5_wp + rdusk(ji,jj) = rdawn(ji,jj) + ENDIF + END DO + END DO + rdawn(:,:) = MOD( (rdawn(:,:) + 1._wp), 1._wp ) + rdusk(:,:) = MOD( (rdusk(:,:) + 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 = 1, jpj + DO ji = 1, jpi + IF ( ABS(rab(ji,jj)) < 1._wp ) THEN ! day duration is less than 24h + rscal(ji,jj) = 0.0_wp + IF ( rdawn(ji,jj) < rdusk(ji,jj) ) THEN ! day time in one part + IF( (rdusk(ji,jj) - rdawn(ji,jj) ) .ge. 0.001_wp ) THEN + rscal(ji,jj) = fintegral(rdawn(ji,jj), rdusk(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(ji,jj) + (1._wp - rdawn(ji,jj)) ) .ge. 0.001_wp ) THEN + rscal(ji,jj) = fintegral(0._wp, rdusk(ji,jj), raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) & + & + fintegral(rdawn(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 / ( rdt * REAL(nn_fsbc, wp) ) + rscal(:,:) = rscal(:,:) * ztmp + ! + ENDIF + ! 3. update qsr with the diurnal cycle + ! ------------------------------------ + + imask_night(:,:) = 0 + DO jj = 1, jpj + DO ji = 1, jpi + ztmpm = 0._wp + IF( ABS(rab(ji,jj)) < 1. ) THEN ! day duration is less than 24h + ! + IF( rdawn(ji,jj) < rdusk(ji,jj) ) THEN ! day time in one part + zlousd = MAX(zlo, rdawn(ji,jj)) + zlousd = MIN(zlousd, zup) + zupusd = MIN(zup, rdusk(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(ji,jj)) + zupusd = MIN(zup, rdusk(ji,jj)) + ztmp1 = fintegral(zlousd, zupusd, raa(ji,jj), rbb(ji,jj), rcc(ji,jj)) + ztmpm1=zupusd-zlousd + zlousd = MAX(zlo, rdawn(ji,jj)) + zupusd = MAX(zup, rdawn(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 + + !!====================================================================== +END MODULE sbcdcy diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcflx.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcflx.F90 new file mode 100644 index 0000000..21574c4 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcflx.F90 @@ -0,0 +1,183 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + REWIND( numnam_ref ) ! Namelist namsbc_flx in reference namelist : Files for fluxes + READ ( numnam_ref, namsbc_flx, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_flx in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_flx in configuration namelist : Files for fluxes + 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' ) + ! + 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 ; qsr(:,:) = sbc_dcy( sf(jp_qsr)%fnow(:,:,1) ) * tmask(:,:,1) ! modify now Qsr to include the diurnal cycle + ELSE ; qsr(:,:) = sf(jp_qsr)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + DO jj = 1, jpj ! set the ocean fluxes from read fields + DO ji = 1, jpi + 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 + ! + ! clem: without these lbc calls, it seems that the northfold is not ok (true in 3.6, not sure in 4.x) + CALL lbc_lnk_multi( 'sbcflx', utau, 'U', -1._wp, vtau, 'V', -1._wp, & + & qns, 'T', 1._wp, emp , 'T', 1._wp, qsr, 'T', 1._wp ) !! sfx, 'T', 1._wp ) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vect. opt. + 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_multi( 'sbcflx', taum, 'T', 1._wp, wndm, 'T', 1._wp ) + ! + ! + END SUBROUTINE sbc_flx + + !!====================================================================== +END MODULE sbcflx diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcfwb.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcfwb.F90 new file mode 100644 index 0000000..4a44e66 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcfwb.F90 @@ -0,0 +1,238 @@ +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 sbc_ice , ONLY : snwice_mass, snwice_mass_b, snwice_fmass + USE phycst ! physical constants + USE sbcrnf ! ocean runoffs + USE sbcisf ! ice shelf melting contribution + 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) :: a_fwb_b ! annual domain averaged freshwater budget + REAL(wp) :: a_fwb ! for 2 year before (_b) and before year. + REAL(wp) :: fwfold ! fwfold to be suppressed + REAL(wp) :: area ! global mean ocean surface (interior domain) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_fwb( kt, kn_fwb, kn_fsbc ) + !!--------------------------------------------------------------------- + !! *** 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 :: inum, ikty, iyear ! 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(wp),DIMENSION(1) :: y_fwfnow + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + 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 == 2 ) WRITE(numout,*) ' adjusted from previous year budget' + IF( kn_fwb == 3 ) WRITE(numout,*) ' fwf set to zero and spread out over erp area' + 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. + ! +#if ! defined key_si3 && ! defined key_cice + 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 + ! + 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(:,:) - 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 + ENDIF + ! + CASE ( 2 ) !== fwf budget adjusted from the previous year ==! + ! + IF( kt == nit000 ) THEN ! initialisation + ! ! Read the corrective factor on precipitations (fwfold) + IF ( ln_rstart .AND. iom_varid( numror, 'a_fwb_b', ldstop = .FALSE. ) > 0 & + & .AND. iom_varid( numror, 'a_fwb', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) 'sbc_fwb : reading FW-budget adjustment from restart file' + CALL iom_get( numror, 'a_fwb_b', a_fwb_b, ldxios = lrxios ) + CALL iom_get( numror, 'a_fwb', a_fwb, ldxios = lrxios ) + ELSE + CALL ctl_opn( inum, 'EMPave_old.dat', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE. ) + READ ( inum, "(24X,I8,2ES24.16)" ) iyear, a_fwb_b, a_fwb + CLOSE( inum ) + END IF + fwfold = a_fwb ! current year freshwater budget correction + ! ! estimate from the previous year budget + IF(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*)'sbc_fwb : year = ',iyear , ' freshwater budget correction = ', fwfold + IF(lwp)WRITE(numout,*)' year = ',iyear-1, ' freshwater budget read = ', a_fwb + IF(lwp)WRITE(numout,*)' year = ',iyear-2, ' freshwater budget read = ', a_fwb_b + ! + IF( lwxios ) THEN ! Activate output of restart variables + CALL iom_set_rstw_var_active( 'a_fwb_b' ) + CALL iom_set_rstw_var_active( 'a_fwb' ) + END IF + ENDIF + ! ! Update fwfold if new year start + ikty = 365 * 86400 / rdt !!bug use of 365 days leap year or 360d year !!!!!!! + IF( MOD( kt, ikty ) == 0 ) THEN + a_fwb_b = a_fwb ! mean sea level taking into account the ice+snow + ! sum over the global domain + a_fwb = glob_sum( 'sbcfwb', e1e2t(:,:) * ( sshn(:,:) + snwice_mass(:,:) * r1_rau0 ) ) + a_fwb = a_fwb * 1.e+3 / ( area * rday * 365. ) ! convert in Kg/m3/s = mm/s +!!gm ! !!bug 365d year + fwfold = a_fwb ! current year freshwater budget correction + ! ! estimate from the previous year budget + ENDIF + ! + IF( MOD( kt-1, kn_fsbc ) == 0 ) THEN ! correct the freshwater fluxes + zcoef = fwfold * rcp + emp(:,:) = emp(:,:) + fwfold * tmask(:,:,1) + qns(:,:) = qns(:,:) - zcoef * sst_m(:,:) * tmask(:,:,1) ! account for change to the heat budget due to fw correction + 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,*) '~~~~' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'a_fwb_b', a_fwb_b, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'a_fwb', a_fwb, ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + END IF + ! + IF( kt == nitend .AND. lwm ) THEN ! save fwfold value in a file (only one required) + CALL ctl_opn( inum, 'EMPave.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) + WRITE( inum, "(24X,I8,2ES24.16)" ) nyear, a_fwb_b, a_fwb + CLOSE( inum ) + 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(:,:) - 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. ) + ! + 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(:,:) + ! + IF( nprint == 1 .AND. 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/NEMO_4.0.4_surge/src/OCE/SBC/sbcice_cice.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcice_cice.F90 new file mode 100644 index 0000000..dab6cc9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcice_cice.F90 @@ -0,0 +1,1072 @@ +MODULE sbcice_cice + !!====================================================================== + !! *** MODULE sbcice_cice *** + !! To couple with sea ice model CICE (LANL) + !!===================================================================== +#if defined key_cice + !!---------------------------------------------------------------------- + !! 'key_cice' : CICE sea-ice model + !!---------------------------------------------------------------------- + !! sbc_ice_cice : sea-ice model time-stepping and update ocean sbc over ice-covered area + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers + USE dom_oce ! ocean space and time domain + USE domvvl + USE phycst, only : rcp, rau0, r1_rau0, rhos, rhoi + USE in_out_manager ! I/O manager + USE iom, ONLY : iom_put,iom_use ! I/O manager library !!Joakim edit + USE lib_mpp ! distributed memory computing library + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE daymod ! calendar + USE fldread ! read input fields + USE sbc_oce ! Surface boundary condition: ocean fields + USE sbc_ice ! Surface boundary condition: ice fields + USE sbcblk ! Surface boundary condition: bulk + USE sbccpl + + USE ice_kinds_mod + USE ice_blocks + USE ice_domain + USE ice_domain_size + USE ice_boundary + USE ice_constants + USE ice_gather_scatter + USE ice_calendar, only: dt + USE ice_state, only: aice,aicen,uvel,vvel,vsno,vsnon,vice,vicen +# if defined key_cice4 + USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & + strocnxT,strocnyT, & + sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_gbm, & + fresh_gbm,fhocn_gbm,fswthru_gbm,frzmlt, & + flatn_f,fsurfn_f,fcondtopn_f, & + uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, & + swvdr,swvdf,swidr,swidf + USE ice_therm_vertical, only: calc_Tsfc +#else + USE ice_flux, only: strax,stray,strocnx,strocny,frain,fsnow, & + strocnxT,strocnyT, & + sst,sss,uocn,vocn,ss_tltx,ss_tlty,fsalt_ai, & + fresh_ai,fhocn_ai,fswthru_ai,frzmlt, & + flatn_f,fsurfn_f,fcondtopn_f, & + uatm,vatm,wind,fsw,flw,Tair,potT,Qa,rhoa,zlvl, & + swvdr,swvdf,swidr,swidf + USE ice_therm_shared, only: calc_Tsfc +#endif + USE ice_forcing, only: frcvdr,frcvdf,frcidr,frcidf + USE ice_atmo, only: calc_strair + + USE CICE_InitMod + USE CICE_RunMod + USE CICE_FinalMod + + IMPLICIT NONE + PRIVATE + + PUBLIC cice_sbc_init ! routine called by sbc_init + PUBLIC cice_sbc_final ! routine called by sbc_final + PUBLIC sbc_ice_cice ! routine called by sbc + + INTEGER :: ji_off + INTEGER :: jj_off + + INTEGER , PARAMETER :: jpfld = 13 ! maximum number of files to read + INTEGER , PARAMETER :: jp_snow = 1 ! index of snow file + INTEGER , PARAMETER :: jp_rain = 2 ! index of rain file + INTEGER , PARAMETER :: jp_sblm = 3 ! index of sublimation file + INTEGER , PARAMETER :: jp_top1 = 4 ! index of category 1 topmelt file + INTEGER , PARAMETER :: jp_top2 = 5 ! index of category 2 topmelt file + INTEGER , PARAMETER :: jp_top3 = 6 ! index of category 3 topmelt file + INTEGER , PARAMETER :: jp_top4 = 7 ! index of category 4 topmelt file + INTEGER , PARAMETER :: jp_top5 = 8 ! index of category 5 topmelt file + INTEGER , PARAMETER :: jp_bot1 = 9 ! index of category 1 botmelt file + INTEGER , PARAMETER :: jp_bot2 = 10 ! index of category 2 botmelt file + INTEGER , PARAMETER :: jp_bot3 = 11 ! index of category 3 botmelt file + INTEGER , PARAMETER :: jp_bot4 = 12 ! index of category 4 botmelt file + INTEGER , PARAMETER :: jp_bot5 = 13 ! index of category 5 botmelt file + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf ! structure of input fields (file informations, fields read) + + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:), PRIVATE :: png ! local array used in sbc_cice_ice + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION sbc_ice_cice_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_ice_cice_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( png(jpi,jpj,jpnij), STAT=sbc_ice_cice_alloc ) + CALL mpp_sum ( 'sbcice_cice', sbc_ice_cice_alloc ) + IF( sbc_ice_cice_alloc > 0 ) CALL ctl_warn('sbc_ice_cice_alloc: allocation of arrays failed.') + END FUNCTION sbc_ice_cice_alloc + + SUBROUTINE sbc_ice_cice( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_ice_cice *** + !! + !! ** Purpose : update the ocean surface boundary condition via the + !! CICE Sea Ice Model time stepping + !! + !! ** Method : - Get any extra forcing fields for CICE + !! - Prepare forcing fields + !! - CICE model time stepping + !! - call the routine that computes mass and + !! heat fluxes at the ice/ocean interface + !! + !! ** Action : - time evolution of the CICE sea-ice model + !! - update all sbc variables below sea-ice: + !! utau, vtau, qns , qsr, emp , sfx + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + INTEGER, INTENT(in) :: ksbc ! surface forcing type + !!---------------------------------------------------------------------- + ! + ! !----------------------! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN ! Ice time-step only ! + ! !----------------------! + + ! Make sure any fluxes required for CICE are set + IF ( ksbc == jp_flx ) THEN + CALL cice_sbc_force(kt) + ELSE IF ( ksbc == jp_purecpl ) THEN + CALL sbc_cpl_ice_flx( fr_i ) + ENDIF + + CALL cice_sbc_in ( kt, ksbc ) + CALL CICE_Run + CALL cice_sbc_out ( kt, ksbc ) + + IF ( ksbc == jp_purecpl ) CALL cice_sbc_hadgam(kt+1) + + ENDIF ! End sea-ice time step only + ! + END SUBROUTINE sbc_ice_cice + + + SUBROUTINE cice_sbc_init( ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_init *** + !! ** Purpose: Initialise ice related fields for NEMO and coupling + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: ksbc ! surface forcing type + REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2 + REAL(wp) :: zcoefu, zcoefv, zcoeff ! local scalar + INTEGER :: ji, jj, jl, jk ! dummy loop indices + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*)'cice_sbc_init' + + ji_off = INT ( (jpiglo - nx_global) / 2 ) + jj_off = INT ( (jpjglo - ny_global) / 2 ) + +#if defined key_nemocice_decomp + ! Pass initial SST from NEMO to CICE so ice is initialised correctly if + ! there is no restart file. + ! Values from a CICE restart file would overwrite this + IF ( .NOT. ln_rstart ) THEN + CALL nemo2cice( tsn(:,:,1,jp_tem) , sst , 'T' , 1.) + ENDIF +#endif + +! Initialize CICE + CALL CICE_Initialize + +! Do some CICE consistency checks + IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN + IF ( calc_strair .OR. calc_Tsfc ) THEN + CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=F and calc_Tsfc=F in ice_in' ) + ENDIF + ELSEIF (ksbc == jp_blk) THEN + IF ( .NOT. (calc_strair .AND. calc_Tsfc) ) THEN + CALL ctl_stop( 'STOP', 'cice_sbc_init : Forcing option requires calc_strair=T and calc_Tsfc=T in ice_in' ) + ENDIF + ENDIF + + +! allocate sbc_ice and sbc_cice arrays + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate arrays' ) + IF( sbc_ice_cice_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_ice_cice_alloc : unable to allocate cice arrays' ) + +! Ensure ocean temperatures are nowhere below freezing if not a NEMO restart + IF( .NOT. ln_rstart ) THEN + tsn(:,:,:,jp_tem) = MAX (tsn(:,:,:,jp_tem),Tocnfrz) + tsb(:,:,:,jp_tem) = tsn(:,:,:,jp_tem) + ENDIF + + fr_iu(:,:)=0.0 + fr_iv(:,:)=0.0 + + CALL cice2nemo(aice,fr_i, 'T', 1. ) + IF ( (ksbc == jp_flx) .OR. (ksbc == jp_purecpl) ) THEN + DO jl=1,ncat + CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) + ENDDO + ENDIF + +! T point to U point +! T point to V point + DO jj=1,jpjm1 + DO ji=1,jpim1 + fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1) + fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1) + ENDDO + ENDDO + + CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. ) + + ! set the snow+ice mass + CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) + CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) + snwice_mass (:,:) = ( rhos * ztmp1(:,:) + rhoi * ztmp2(:,:) ) + snwice_mass_b(:,:) = snwice_mass(:,:) + + IF( .NOT.ln_rstart ) THEN + IF( ln_ice_embd ) THEN ! embedded sea-ice: deplete the initial ssh below sea-ice area + sshn(:,:) = sshn(:,:) - snwice_mass(:,:) * r1_rau0 + sshb(:,:) = sshb(:,:) - snwice_mass(:,:) * r1_rau0 + +!!gm This should be put elsewhere.... (same remark for limsbc) +!!gm especially here it is assumed zstar coordinate, but it can be ztilde.... + IF( .NOT.ln_linssh ) THEN + ! + DO jk = 1,jpkm1 ! adjust initial vertical scale factors + e3t_n(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshn(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) + e3t_b(:,:,jk) = e3t_0(:,:,jk)*( 1._wp + sshb(:,:)*tmask(:,:,1)/(ht_0(:,:) + 1.0 - tmask(:,:,1)) ) + ENDDO + e3t_a(:,:,:) = e3t_b(:,:,:) + ! Reconstruction of all vertical scale factors at now and before time-steps + ! ============================================================================= + ! Horizontal scale factor interpolations + ! -------------------------------------- + CALL dom_vvl_interpol( e3t_b(:,:,:), e3u_b(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_b(:,:,:), e3v_b(:,:,:), 'V' ) + CALL dom_vvl_interpol( e3t_n(:,:,:), e3u_n(:,:,:), 'U' ) + CALL dom_vvl_interpol( e3t_n(:,:,:), e3v_n(:,:,:), 'V' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3f_n(:,:,:), 'F' ) + ! Vertical scale factor interpolations + ! ------------------------------------ + CALL dom_vvl_interpol( e3t_n(:,:,:), e3w_n (:,:,:), 'W' ) + CALL dom_vvl_interpol( e3u_n(:,:,:), e3uw_n(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_n(:,:,:), e3vw_n(:,:,:), 'VW' ) + CALL dom_vvl_interpol( e3u_b(:,:,:), e3uw_b(:,:,:), 'UW' ) + CALL dom_vvl_interpol( e3v_b(:,:,:), e3vw_b(:,:,:), 'VW' ) + ! t- and w- points depth + ! ---------------------- + gdept_n(:,:,1) = 0.5_wp * e3w_n(:,:,1) + gdepw_n(:,:,1) = 0.0_wp + gde3w_n(:,:,1) = gdept_n(:,:,1) - sshn(:,:) + DO jk = 2, jpk + gdept_n(:,:,jk) = gdept_n(:,:,jk-1) + e3w_n(:,:,jk) + gdepw_n(:,:,jk) = gdepw_n(:,:,jk-1) + e3t_n(:,:,jk-1) + gde3w_n(:,:,jk) = gdept_n(:,:,jk ) - sshn (:,:) + END DO + ENDIF + ENDIF + ENDIF + ! + END SUBROUTINE cice_sbc_init + + + SUBROUTINE cice_sbc_in( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_in *** + !! ** Purpose: Set coupling fields and pass to CICE + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + INTEGER, INTENT(in ) :: ksbc ! surface forcing type + ! + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztmp, zpice + REAL(wp), DIMENSION(jpi,jpj,ncat) :: ztmpn + REAL(wp) :: zintb, zintn ! dummy argument + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*)'cice_sbc_in' + ENDIF + + ztmp(:,:)=0.0 + +! Aggregate ice concentration already set in cice_sbc_out (or cice_sbc_init on +! the first time-step) + +! forced and coupled case + + IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN + + ztmpn(:,:,:)=0.0 + +! x comp of wind stress (CI_1) +! U point to F point + DO jj=1,jpjm1 + DO ji=1,jpi + ztmp(ji,jj) = 0.5 * ( fr_iu(ji,jj) * utau(ji,jj) & + + fr_iu(ji,jj+1) * utau(ji,jj+1) ) * fmask(ji,jj,1) + ENDDO + ENDDO + CALL nemo2cice(ztmp,strax,'F', -1. ) + +! y comp of wind stress (CI_2) +! V point to F point + DO jj=1,jpj + DO ji=1,jpim1 + ztmp(ji,jj) = 0.5 * ( fr_iv(ji,jj) * vtau(ji,jj) & + + fr_iv(ji+1,jj) * vtau(ji+1,jj) ) * fmask(ji,jj,1) + ENDDO + ENDDO + CALL nemo2cice(ztmp,stray,'F', -1. ) + +! Surface downward latent heat flux (CI_5) + IF (ksbc == jp_flx) THEN + DO jl=1,ncat + ztmpn(:,:,jl)=qla_ice(:,:,1)*a_i(:,:,jl) + ENDDO + ELSE +! emp_ice is set in sbc_cpl_ice_flx as sublimation-snow + qla_ice(:,:,1)= - ( emp_ice(:,:)+sprecip(:,:) ) * rLsub +! End of temporary code + DO jj=1,jpj + DO ji=1,jpi + IF (fr_i(ji,jj).eq.0.0) THEN + DO jl=1,ncat + ztmpn(ji,jj,jl)=0.0 + ENDDO + ! This will then be conserved in CICE + ztmpn(ji,jj,1)=qla_ice(ji,jj,1) + ELSE + DO jl=1,ncat + ztmpn(ji,jj,jl)=qla_ice(ji,jj,1)*a_i(ji,jj,jl)/fr_i(ji,jj) + ENDDO + ENDIF + ENDDO + ENDDO + ENDIF + DO jl=1,ncat + CALL nemo2cice(ztmpn(:,:,jl),flatn_f(:,:,jl,:),'T', 1. ) + +! GBM conductive flux through ice (CI_6) +! Convert to GBM + IF (ksbc == jp_flx) THEN + ztmp(:,:) = botmelt(:,:,jl)*a_i(:,:,jl) + ELSE + ztmp(:,:) = botmelt(:,:,jl) + ENDIF + CALL nemo2cice(ztmp,fcondtopn_f(:,:,jl,:),'T', 1. ) + +! GBM surface heat flux (CI_7) +! Convert to GBM + IF (ksbc == jp_flx) THEN + ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl))*a_i(:,:,jl) + ELSE + ztmp(:,:) = (topmelt(:,:,jl)+botmelt(:,:,jl)) + ENDIF + CALL nemo2cice(ztmp,fsurfn_f(:,:,jl,:),'T', 1. ) + ENDDO + + ELSE IF (ksbc == jp_blk) THEN + +! Pass bulk forcing fields to CICE (which will calculate heat fluxes etc itself) +! x comp and y comp of atmosphere surface wind (CICE expects on T points) + ztmp(:,:) = wndi_ice(:,:) + CALL nemo2cice(ztmp,uatm,'T', -1. ) + ztmp(:,:) = wndj_ice(:,:) + CALL nemo2cice(ztmp,vatm,'T', -1. ) + ztmp(:,:) = SQRT ( wndi_ice(:,:)**2 + wndj_ice(:,:)**2 ) + CALL nemo2cice(ztmp,wind,'T', 1. ) ! Wind speed (m/s) + ztmp(:,:) = qsr_ice(:,:,1) + CALL nemo2cice(ztmp,fsw,'T', 1. ) ! Incoming short-wave (W/m^2) + ztmp(:,:) = qlw_ice(:,:,1) + CALL nemo2cice(ztmp,flw,'T', 1. ) ! Incoming long-wave (W/m^2) + ztmp(:,:) = tatm_ice(:,:) + CALL nemo2cice(ztmp,Tair,'T', 1. ) ! Air temperature (K) + CALL nemo2cice(ztmp,potT,'T', 1. ) ! Potential temp (K) +! Following line uses MAX(....) to avoid problems if tatm_ice has unset halo rows + ztmp(:,:) = 101000. / ( 287.04 * MAX(1.0,tatm_ice(:,:)) ) + ! Constant (101000.) atm pressure assumed + CALL nemo2cice(ztmp,rhoa,'T', 1. ) ! Air density (kg/m^3) + ztmp(:,:) = qatm_ice(:,:) + CALL nemo2cice(ztmp,Qa,'T', 1. ) ! Specific humidity (kg/kg) + ztmp(:,:)=10.0 + CALL nemo2cice(ztmp,zlvl,'T', 1. ) ! Atmos level height (m) + +! May want to check all values are physically realistic (as in CICE routine +! prepare_forcing)? + +! Divide shortwave into spectral bands (as in prepare_forcing) + ztmp(:,:)=qsr_ice(:,:,1)*frcvdr ! visible direct + CALL nemo2cice(ztmp,swvdr,'T', 1. ) + ztmp(:,:)=qsr_ice(:,:,1)*frcvdf ! visible diffuse + CALL nemo2cice(ztmp,swvdf,'T', 1. ) + ztmp(:,:)=qsr_ice(:,:,1)*frcidr ! near IR direct + CALL nemo2cice(ztmp,swidr,'T', 1. ) + ztmp(:,:)=qsr_ice(:,:,1)*frcidf ! near IR diffuse + CALL nemo2cice(ztmp,swidf,'T', 1. ) + + ENDIF + +! Snowfall +! Ensure fsnow is positive (as in CICE routine prepare_forcing) + IF( iom_use('snowpre') ) CALL iom_put('snowpre',MAX( (1.0-fr_i(:,:))*sprecip(:,:) ,0.0)) !!Joakim edit + ztmp(:,:)=MAX(fr_i(:,:)*sprecip(:,:),0.0) + CALL nemo2cice(ztmp,fsnow,'T', 1. ) + +! Rainfall + IF( iom_use('precip') ) CALL iom_put('precip', (1.0-fr_i(:,:))*(tprecip(:,:)-sprecip(:,:)) ) !!Joakim edit + ztmp(:,:)=fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) + CALL nemo2cice(ztmp,frain,'T', 1. ) + +! Freezing/melting potential +! Calculated over NEMO leapfrog timestep (hence 2*dt) + nfrzmlt(:,:) = rau0 * rcp * e3t_m(:,:) * ( Tocnfrz-sst_m(:,:) ) / ( 2.0*dt ) + + ztmp(:,:) = nfrzmlt(:,:) + CALL nemo2cice(ztmp,frzmlt,'T', 1. ) + +! SST and SSS + + CALL nemo2cice(sst_m,sst,'T', 1. ) + CALL nemo2cice(sss_m,sss,'T', 1. ) + +! x comp and y comp of surface ocean current +! U point to F point + DO jj=1,jpjm1 + DO ji=1,jpi + ztmp(ji,jj)=0.5*(ssu_m(ji,jj)+ssu_m(ji,jj+1))*fmask(ji,jj,1) + ENDDO + ENDDO + CALL nemo2cice(ztmp,uocn,'F', -1. ) + +! V point to F point + DO jj=1,jpj + DO ji=1,jpim1 + ztmp(ji,jj)=0.5*(ssv_m(ji,jj)+ssv_m(ji+1,jj))*fmask(ji,jj,1) + ENDDO + ENDDO + CALL nemo2cice(ztmp,vocn,'F', -1. ) + + IF( ln_ice_embd ) THEN !== embedded sea ice: compute representative ice top surface ==! + ! + ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[n/nn_fsbc], n=0,nn_fsbc-1} + ! = (1/nn_fsbc)^2 * {SUM[n], n=0,nn_fsbc-1} + zintn = REAL( nn_fsbc - 1 ) / REAL( nn_fsbc ) * 0.5_wp + ! + ! average interpolation coeff as used in dynspg = (1/nn_fsbc) * {SUM[1-n/nn_fsbc], n=0,nn_fsbc-1} + ! = (1/nn_fsbc)^2 * (nn_fsbc^2 - {SUM[n], n=0,nn_fsbc-1}) + zintb = REAL( nn_fsbc + 1 ) / REAL( nn_fsbc ) * 0.5_wp + ! + zpice(:,:) = ssh_m(:,:) + ( zintn * snwice_mass(:,:) + zintb * snwice_mass_b(:,:) ) * r1_rau0 + ! + ! + ELSE !== non-embedded sea ice: use ocean surface for slope calculation ==! + zpice(:,:) = ssh_m(:,:) + ENDIF + +! x comp and y comp of sea surface slope (on F points) +! T point to F point + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + ztmp(ji,jj)=0.5 * ( (zpice(ji+1,jj )-zpice(ji,jj )) * r1_e1u(ji,jj ) & + & + (zpice(ji+1,jj+1)-zpice(ji,jj+1)) * r1_e1u(ji,jj+1) ) * fmask(ji,jj,1) + END DO + END DO + CALL nemo2cice( ztmp,ss_tltx,'F', -1. ) + +! T point to F point + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + ztmp(ji,jj)=0.5 * ( (zpice(ji ,jj+1)-zpice(ji ,jj)) * r1_e2v(ji ,jj) & + & + (zpice(ji+1,jj+1)-zpice(ji+1,jj)) * r1_e2v(ji+1,jj) ) * fmask(ji,jj,1) + END DO + END DO + CALL nemo2cice(ztmp,ss_tlty,'F', -1. ) + ! + END SUBROUTINE cice_sbc_in + + + SUBROUTINE cice_sbc_out( kt, ksbc ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_out *** + !! ** Purpose: Get fields from CICE and set surface fields for NEMO + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + INTEGER, INTENT( in ) :: ksbc ! surface forcing type + + INTEGER :: ji, jj, jl ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztmp1, ztmp2 + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*)'cice_sbc_out' + ENDIF + +! x comp of ocean-ice stress + CALL cice2nemo(strocnx,ztmp1,'F', -1. ) + ss_iou(:,:)=0.0 +! F point to U point + DO jj=2,jpjm1 + DO ji=2,jpim1 + ss_iou(ji,jj) = 0.5 * ( ztmp1(ji,jj-1) + ztmp1(ji,jj) ) * umask(ji,jj,1) + ENDDO + ENDDO + CALL lbc_lnk( 'sbcice_cice', ss_iou , 'U', -1. ) + +! y comp of ocean-ice stress + CALL cice2nemo(strocny,ztmp1,'F', -1. ) + ss_iov(:,:)=0.0 +! F point to V point + + DO jj=1,jpjm1 + DO ji=2,jpim1 + ss_iov(ji,jj) = 0.5 * ( ztmp1(ji-1,jj) + ztmp1(ji,jj) ) * vmask(ji,jj,1) + ENDDO + ENDDO + CALL lbc_lnk( 'sbcice_cice', ss_iov , 'V', -1. ) + +! x and y comps of surface stress +! Combine wind stress and ocean-ice stress +! [Note that fr_iu hasn't yet been updated, so still from start of CICE timestep] +! strocnx and strocny already weighted by ice fraction in CICE so not done here + + utau(:,:)=(1.0-fr_iu(:,:))*utau(:,:)-ss_iou(:,:) + vtau(:,:)=(1.0-fr_iv(:,:))*vtau(:,:)-ss_iov(:,:) + +! Also need ice/ocean stress on T points so that taum can be updated +! This interpolation is already done in CICE so best to use those values + CALL cice2nemo(strocnxT,ztmp1,'T',-1.) + CALL cice2nemo(strocnyT,ztmp2,'T',-1.) + +! Update taum with modulus of ice-ocean stress +! strocnxT and strocnyT are not weighted by ice fraction in CICE so must be done here +taum(:,:)=(1.0-fr_i(:,:))*taum(:,:)+fr_i(:,:)*SQRT(ztmp1*ztmp1 + ztmp2*ztmp2) + +! Freshwater fluxes + + IF (ksbc == jp_flx) THEN +! Note that emp from the forcing files is evap*(1-aice)-(tprecip-aice*sprecip) +! What we want here is evap*(1-aice)-tprecip*(1-aice) hence manipulation below +! Not ideal since aice won't be the same as in the atmosphere. +! Better to use evap and tprecip? (but for now don't read in evap in this case) + emp(:,:) = emp(:,:)+fr_i(:,:)*(tprecip(:,:)-sprecip(:,:)) + ELSE IF (ksbc == jp_blk) THEN + emp(:,:) = (1.0-fr_i(:,:))*emp(:,:) + ELSE IF (ksbc == jp_purecpl) THEN +! emp_tot is set in sbc_cpl_ice_flx (called from cice_sbc_in above) +! This is currently as required with the coupling fields from the UM atmosphere + emp(:,:) = emp_tot(:,:)+tprecip(:,:)*fr_i(:,:) + ENDIF + +#if defined key_cice4 + CALL cice2nemo(fresh_gbm,ztmp1,'T', 1. ) + CALL cice2nemo(fsalt_gbm,ztmp2,'T', 1. ) +#else + CALL cice2nemo(fresh_ai,ztmp1,'T', 1. ) + CALL cice2nemo(fsalt_ai,ztmp2,'T', 1. ) +#endif + +! Check to avoid unphysical expression when ice is forming (ztmp1 negative) +! Otherwise we are effectively allowing ice of higher salinity than the ocean to form +! which has to be compensated for by the ocean salinity potentially going negative +! This check breaks conservation but seems reasonable until we have prognostic ice salinity +! Note the 1000.0 below is to convert from kg salt to g salt (needed for PSU) + WHERE (ztmp1(:,:).lt.0.0) ztmp2(:,:)=MAX(ztmp2(:,:),ztmp1(:,:)*sss_m(:,:)/1000.0) + sfx(:,:)=ztmp2(:,:)*1000.0 + emp(:,:)=emp(:,:)-ztmp1(:,:) + fmmflx(:,:) = ztmp1(:,:) !!Joakim edit + + CALL lbc_lnk_multi( 'sbcice_cice', emp , 'T', 1., sfx , 'T', 1. ) + +! Solar penetrative radiation and non solar surface heat flux + +! Scale qsr and qns according to ice fraction (bulk formulae only) + + IF (ksbc == jp_blk) THEN + qsr(:,:)=qsr(:,:)*(1.0-fr_i(:,:)) + qns(:,:)=qns(:,:)*(1.0-fr_i(:,:)) + ENDIF +! Take into account snow melting except for fully coupled when already in qns_tot + IF (ksbc == jp_purecpl) THEN + qsr(:,:)= qsr_tot(:,:) + qns(:,:)= qns_tot(:,:) + ELSE + qns(:,:)= qns(:,:)-sprecip(:,:)*Lfresh*(1.0-fr_i(:,:)) + ENDIF + +! Now add in ice / snow related terms +! [fswthru will be zero unless running with calc_Tsfc=T in CICE] +#if defined key_cice4 + CALL cice2nemo(fswthru_gbm,ztmp1,'T', 1. ) +#else + CALL cice2nemo(fswthru_ai,ztmp1,'T', 1. ) +#endif + qsr(:,:)=qsr(:,:)+ztmp1(:,:) + CALL lbc_lnk( 'sbcice_cice', qsr , 'T', 1. ) + + DO jj=1,jpj + DO ji=1,jpi + nfrzmlt(ji,jj)=MAX(nfrzmlt(ji,jj),0.0) + ENDDO + ENDDO + +#if defined key_cice4 + CALL cice2nemo(fhocn_gbm,ztmp1,'T', 1. ) +#else + CALL cice2nemo(fhocn_ai,ztmp1,'T', 1. ) +#endif + qns(:,:)=qns(:,:)+nfrzmlt(:,:)+ztmp1(:,:) + + CALL lbc_lnk( 'sbcice_cice', qns , 'T', 1. ) + +! Prepare for the following CICE time-step + + CALL cice2nemo(aice,fr_i,'T', 1. ) + IF ( (ksbc == jp_flx).OR.(ksbc == jp_purecpl) ) THEN + DO jl=1,ncat + CALL cice2nemo(aicen(:,:,jl,:),a_i(:,:,jl), 'T', 1. ) + ENDDO + ENDIF + +! T point to U point +! T point to V point + DO jj=1,jpjm1 + DO ji=1,jpim1 + fr_iu(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji+1,jj))*umask(ji,jj,1) + fr_iv(ji,jj)=0.5*(fr_i(ji,jj)+fr_i(ji,jj+1))*vmask(ji,jj,1) + ENDDO + ENDDO + + CALL lbc_lnk_multi( 'sbcice_cice', fr_iu , 'U', 1., fr_iv , 'V', 1. ) + + ! set the snow+ice mass + CALL cice2nemo(vsno(:,:,:),ztmp1,'T', 1. ) + CALL cice2nemo(vice(:,:,:),ztmp2,'T', 1. ) + snwice_mass (:,:) = ( rhos * ztmp1(:,:) + rhoi * ztmp2(:,:) ) + snwice_mass_b(:,:) = snwice_mass(:,:) + snwice_fmass (:,:) = ( snwice_mass(:,:) - snwice_mass_b(:,:) ) / dt + ! + END SUBROUTINE cice_sbc_out + + + SUBROUTINE cice_sbc_hadgam( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_hadgam *** + !! ** Purpose: Prepare fields needed to pass to HadGAM3 atmosphere + !! + !! + !!--------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time step + !! + INTEGER :: jl ! dummy loop index + INTEGER :: ierror + !!--------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*)'cice_sbc_hadgam' + IF( sbc_cpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_cpl_alloc : unable to allocate arrays' ) + ENDIF + + ! ! =========================== ! + ! ! Prepare Coupling fields ! + ! ! =========================== ! + ! + ! x and y comp of ice velocity + ! + CALL cice2nemo(uvel,u_ice,'F', -1. ) + CALL cice2nemo(vvel,v_ice,'F', -1. ) + ! + ! Ice concentration (CO_1) = a_i calculated at end of cice_sbc_out + ! + ! Snow and ice thicknesses (CO_2 and CO_3) + ! + DO jl = 1, ncat + CALL cice2nemo( vsnon(:,:,jl,:), h_s(:,:,jl),'T', 1. ) + CALL cice2nemo( vicen(:,:,jl,:), h_i(:,:,jl),'T', 1. ) + END DO + ! + END SUBROUTINE cice_sbc_hadgam + + + SUBROUTINE cice_sbc_final + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_final *** + !! ** Purpose: Finalize CICE + !!--------------------------------------------------------------------- + ! + IF(lwp) WRITE(numout,*)'cice_sbc_final' + ! + CALL CICE_Finalize + ! + END SUBROUTINE cice_sbc_final + + + SUBROUTINE cice_sbc_force (kt) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice_sbc_force *** + !! ** Purpose : Provide CICE forcing from files + !! + !!--------------------------------------------------------------------- + !! ** Method : READ monthly flux file in NetCDF files + !! + !! snowfall + !! rainfall + !! sublimation rate + !! topmelt (category) + !! botmelt (category) + !! + !! History : + !!---------------------------------------------------------------------- + USE iom + !! + INTEGER, INTENT( in ) :: kt ! ocean time step + !! + INTEGER :: ierror ! return error code + INTEGER :: ifpr ! dummy loop index + !! + CHARACTER(len=100) :: cn_dir ! Root directory for location of CICE forcing files + TYPE(FLD_N), DIMENSION(jpfld) :: slf_i ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_snow, sn_rain, sn_sblm ! informations about the fields to be read + TYPE(FLD_N) :: sn_top1, sn_top2, sn_top3, sn_top4, sn_top5 + TYPE(FLD_N) :: sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 + !! + NAMELIST/namsbc_cice/ cn_dir, sn_snow, sn_rain, sn_sblm, & + & sn_top1, sn_top2, sn_top3, sn_top4, sn_top5, & + & sn_bot1, sn_bot2, sn_bot3, sn_bot4, sn_bot5 + INTEGER :: ios + !!--------------------------------------------------------------------- + + ! ! ====================== ! + IF( kt == nit000 ) THEN ! First call kt=nit000 ! + ! ! ====================== ! + ! namsbc_cice is not yet in the reference namelist + ! set file information (default values) + cn_dir = './' ! directory in which the model is executed + + ! (NB: frequency positive => hours, negative => months) + ! ! file ! frequency ! variable ! time intep ! clim ! 'yearly' or ! weights ! rotation ! landmask + ! ! name ! (hours) ! name ! (T/F) ! (T/F) ! 'monthly' ! filename ! pairs ! file + sn_snow = FLD_N( 'snowfall_1m' , -1. , 'snowfall' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_rain = FLD_N( 'rainfall_1m' , -1. , 'rainfall' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_sblm = FLD_N( 'sublim_1m' , -1. , 'sublim' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top1 = FLD_N( 'topmeltn1_1m' , -1. , 'topmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top2 = FLD_N( 'topmeltn2_1m' , -1. , 'topmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top3 = FLD_N( 'topmeltn3_1m' , -1. , 'topmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top4 = FLD_N( 'topmeltn4_1m' , -1. , 'topmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_top5 = FLD_N( 'topmeltn5_1m' , -1. , 'topmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot1 = FLD_N( 'botmeltn1_1m' , -1. , 'botmeltn1' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot2 = FLD_N( 'botmeltn2_1m' , -1. , 'botmeltn2' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot3 = FLD_N( 'botmeltn3_1m' , -1. , 'botmeltn3' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot4 = FLD_N( 'botmeltn4_1m' , -1. , 'botmeltn4' , .true. , .true. , ' yearly' , '' , '' , '' ) + sn_bot5 = FLD_N( 'botmeltn5_1m' , -1. , 'botmeltn5' , .true. , .true. , ' yearly' , '' , '' , '' ) + + REWIND( numnam_ref ) ! Namelist namsbc_cice in reference namelist : + READ ( numnam_ref, namsbc_cice, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_cice in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_cice in configuration namelist : Parameters of the run + READ ( numnam_cfg, namsbc_cice, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_cice in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_cice ) + + ! store namelist information in an array + slf_i(jp_snow) = sn_snow ; slf_i(jp_rain) = sn_rain ; slf_i(jp_sblm) = sn_sblm + slf_i(jp_top1) = sn_top1 ; slf_i(jp_top2) = sn_top2 ; slf_i(jp_top3) = sn_top3 + slf_i(jp_top4) = sn_top4 ; slf_i(jp_top5) = sn_top5 ; slf_i(jp_bot1) = sn_bot1 + slf_i(jp_bot2) = sn_bot2 ; slf_i(jp_bot3) = sn_bot3 ; slf_i(jp_bot4) = sn_bot4 + slf_i(jp_bot5) = sn_bot5 + + ! set sf structure + ALLOCATE( sf(jpfld), STAT=ierror ) + IF( ierror > 0 ) THEN + CALL ctl_stop( 'cice_sbc_force: unable to allocate sf structure' ) ; RETURN + ENDIF + + DO ifpr= 1, jpfld + ALLOCATE( sf(ifpr)%fnow(jpi,jpj,1) ) + ALLOCATE( sf(ifpr)%fdta(jpi,jpj,1,2) ) + END DO + + ! fill sf with slf_i and control print + CALL fld_fill( sf, slf_i, cn_dir, 'cice_sbc_force', 'flux formulation for CICE', 'namsbc_cice' ) + ! + ENDIF + + CALL fld_read( kt, nn_fsbc, sf ) ! Read input fields and provides the + ! ! input fields at the current time-step + + ! set the fluxes from read fields + sprecip(:,:) = sf(jp_snow)%fnow(:,:,1) + tprecip(:,:) = sf(jp_snow)%fnow(:,:,1)+sf(jp_rain)%fnow(:,:,1) +! May be better to do this conversion somewhere else + qla_ice(:,:,1) = -rLsub*sf(jp_sblm)%fnow(:,:,1) + topmelt(:,:,1) = sf(jp_top1)%fnow(:,:,1) + topmelt(:,:,2) = sf(jp_top2)%fnow(:,:,1) + topmelt(:,:,3) = sf(jp_top3)%fnow(:,:,1) + topmelt(:,:,4) = sf(jp_top4)%fnow(:,:,1) + topmelt(:,:,5) = sf(jp_top5)%fnow(:,:,1) + botmelt(:,:,1) = sf(jp_bot1)%fnow(:,:,1) + botmelt(:,:,2) = sf(jp_bot2)%fnow(:,:,1) + botmelt(:,:,3) = sf(jp_bot3)%fnow(:,:,1) + botmelt(:,:,4) = sf(jp_bot4)%fnow(:,:,1) + botmelt(:,:,5) = sf(jp_bot5)%fnow(:,:,1) + + ! control print (if less than 100 time-step asked) + IF( nitend-nit000 <= 100 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) ' read forcing fluxes for CICE OK' + CALL FLUSH(numout) + ENDIF + + END SUBROUTINE cice_sbc_force + + SUBROUTINE nemo2cice( pn, pc, cd_type, psgn) + !!--------------------------------------------------------------------- + !! *** ROUTINE nemo2cice *** + !! ** Purpose : Transfer field in NEMO array to field in CICE array. +#if defined key_nemocice_decomp + !! + !! NEMO and CICE PE sub domains are identical, hence + !! there is no need to gather or scatter data from + !! one PE configuration to another. +#else + !! Automatically gather/scatter between + !! different processors and blocks + !! ** Method : A. Ensure all haloes are filled in NEMO field (pn) + !! B. Gather pn into global array (png) + !! C. Map png into CICE global array (pcg) + !! D. Scatter pcg to CICE blocks (pc) + update haloes +#endif + !!--------------------------------------------------------------------- + CHARACTER(len=1), INTENT( in ) :: & + cd_type ! nature of pn grid-point + ! ! = T or F gridpoints + REAL(wp), INTENT( in ) :: & + psgn ! control of the sign change + ! ! =-1 , the sign is modified following the type of b.c. used + ! ! = 1 , no sign change + REAL(wp), DIMENSION(jpi,jpj) :: pn +#if !defined key_nemocice_decomp + REAL(wp), DIMENSION(jpiglo,jpjglo) :: png2 + REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg +#endif + REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc + INTEGER (int_kind) :: & + field_type, &! id for type of field (scalar, vector, angle) + grid_loc ! id for location on horizontal grid + ! (center, NEcorner, Nface, Eface) + + INTEGER :: ji, jj, jn ! dummy loop indices + !!--------------------------------------------------------------------- + +! A. Ensure all haloes are filled in NEMO field (pn) + + CALL lbc_lnk( 'sbcice_cice', pn , cd_type, psgn ) + +#if defined key_nemocice_decomp + + ! Copy local domain data from NEMO to CICE field + pc(:,:,1)=0.0 + DO jj=2,ny_block-1 + DO ji=2,nx_block-1 + pc(ji,jj,1)=pn(ji-1+ji_off,jj-1+jj_off) + ENDDO + ENDDO + +#else + +! B. Gather pn into global array (png) + + IF ( jpnij > 1) THEN + CALL mppsync + CALL mppgather (pn,0,png) + CALL mppsync + ELSE + png(:,:,1)=pn(:,:) + ENDIF + +! C. Map png into CICE global array (pcg) + +! Need to make sure this is robust to changes in NEMO halo rows.... +! (may be OK but not 100% sure) + + IF (nproc==0) THEN +! pcg(:,:)=0.0 + DO jn=1,jpnij + DO jj=nldjt(jn),nlejt(jn) + DO ji=nldit(jn),nleit(jn) + png2(ji+nimppt(jn)-1,jj+njmppt(jn)-1)=png(ji,jj,jn) + ENDDO + ENDDO + ENDDO + DO jj=1,ny_global + DO ji=1,nx_global + pcg(ji,jj)=png2(ji+ji_off,jj+jj_off) + ENDDO + ENDDO + ENDIF + +#endif + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + grid_loc=field_loc_center + CASE ( 'F' ) + grid_loc=field_loc_NEcorner + END SELECT + + SELECT CASE ( NINT(psgn) ) + CASE ( -1 ) + field_type=field_type_vector + CASE ( 1 ) + field_type=field_type_scalar + END SELECT + +#if defined key_nemocice_decomp + ! Ensure CICE halos are up to date + CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type) +#else +! D. Scatter pcg to CICE blocks (pc) + update halos + CALL scatter_global(pc, pcg, 0, distrb_info, grid_loc, field_type) +#endif + + END SUBROUTINE nemo2cice + + SUBROUTINE cice2nemo ( pc, pn, cd_type, psgn ) + !!--------------------------------------------------------------------- + !! *** ROUTINE cice2nemo *** + !! ** Purpose : Transfer field in CICE array to field in NEMO array. +#if defined key_nemocice_decomp + !! + !! NEMO and CICE PE sub domains are identical, hence + !! there is no need to gather or scatter data from + !! one PE configuration to another. +#else + !! Automatically deal with scatter/gather between + !! different processors and blocks + !! ** Method : A. Gather CICE blocks (pc) into global array (pcg) + !! B. Map pcg into NEMO global array (png) + !! C. Scatter png into NEMO field (pn) for each processor + !! D. Ensure all haloes are filled in pn +#endif + !!--------------------------------------------------------------------- + + CHARACTER(len=1), INTENT( in ) :: & + cd_type ! nature of pn grid-point + ! ! = T or F gridpoints + REAL(wp), INTENT( in ) :: & + psgn ! control of the sign change + ! ! =-1 , the sign is modified following the type of b.c. used + ! ! = 1 , no sign change + REAL(wp), DIMENSION(jpi,jpj) :: pn + +#if defined key_nemocice_decomp + INTEGER (int_kind) :: & + field_type, & ! id for type of field (scalar, vector, angle) + grid_loc ! id for location on horizontal grid + ! (center, NEcorner, Nface, Eface) +#else + REAL (kind=dbl_kind), dimension(nx_global,ny_global) :: pcg +#endif + + REAL (kind=dbl_kind), dimension(nx_block,ny_block,max_blocks) :: pc + + INTEGER :: ji, jj, jn ! dummy loop indices + + +#if defined key_nemocice_decomp + + SELECT CASE ( cd_type ) + CASE ( 'T' ) + grid_loc=field_loc_center + CASE ( 'F' ) + grid_loc=field_loc_NEcorner + END SELECT + + SELECT CASE ( NINT(psgn) ) + CASE ( -1 ) + field_type=field_type_vector + CASE ( 1 ) + field_type=field_type_scalar + END SELECT + + CALL ice_HaloUpdate (pc, halo_info, grid_loc, field_type) + + + pn(:,:)=0.0 + DO jj=1,jpjm1 + DO ji=1,jpim1 + pn(ji,jj)=pc(ji+1-ji_off,jj+1-jj_off,1) + ENDDO + ENDDO + +#else + +! A. Gather CICE blocks (pc) into global array (pcg) + + CALL gather_global(pcg, pc, 0, distrb_info) + +! B. Map pcg into NEMO global array (png) + +! Need to make sure this is robust to changes in NEMO halo rows.... +! (may be OK but not spent much time thinking about it) +! Note that non-existent pcg elements may be used below, but +! the lbclnk call on pn will replace these with sensible values + + IF (nproc==0) THEN + png(:,:,:)=0.0 + DO jn=1,jpnij + DO jj=nldjt(jn),nlejt(jn) + DO ji=nldit(jn),nleit(jn) + png(ji,jj,jn)=pcg(ji+nimppt(jn)-1-ji_off,jj+njmppt(jn)-1-jj_off) + ENDDO + ENDDO + ENDDO + ENDIF + +! C. Scatter png into NEMO field (pn) for each processor + + IF ( jpnij > 1) THEN + CALL mppsync + CALL mppscatter (png,0,pn) + CALL mppsync + ELSE + pn(:,:)=png(:,:,1) + ENDIF + +#endif + +! D. Ensure all haloes are filled in pn + + CALL lbc_lnk( 'sbcice_cice', pn , cd_type, psgn ) + + END SUBROUTINE cice2nemo + +#else + !!---------------------------------------------------------------------- + !! 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) ! Dummy routine + IMPLICIT NONE + INTEGER, INTENT( in ) :: ksbc + 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 + +#endif + + !!====================================================================== +END MODULE sbcice_cice diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcice_if.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcice_if.F90 new file mode 100644 index 0000000..c303563 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcice_if.F90 @@ -0,0 +1,149 @@ +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 +#if defined key_si3 + USE ice , ONLY : a_i +#else + USE sbc_ice , ONLY : a_i +#endif + ! + 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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ice_if( kt ) + !!--------------------------------------------------------------------- + !! *** 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 :: 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 + REWIND( numnam_ref ) ! Namelist namsbc_iif in reference namelist : Ice if file + READ ( numnam_ref, namsbc_iif, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_iif in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist Namelist namsbc_iif in configuration namelist : Ice if file + 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 = 1, jpj + DO ji = 1, jpi + ! + 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 + + tsn(ji,jj,1,jp_tem) = MAX( tsn(ji,jj,1,jp_tem), 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 * ( tsb(ji,jj,1,jp_tem) - ( zt_fzp - 1.) ) + zqrj = ztrp * MIN( 0., tsb(ji,jj,1,jp_tem) - 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/NEMO_4.0.4_surge/src/OCE/SBC/sbcisf.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcisf.F90 new file mode 100644 index 0000000..f88ff98 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcisf.F90 @@ -0,0 +1,909 @@ +MODULE sbcisf + !!====================================================================== + !! *** MODULE sbcisf *** + !! Surface module : update surface 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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_isf : update sbc under ice shelf + !!---------------------------------------------------------------------- + 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 zdfdrg ! vertical physics: top/bottom drag coef. + ! + USE in_out_manager ! I/O manager + USE iom ! I/O library + USE fldread ! read input field at current time step + USE lbclnk ! + USE lib_fortran ! glob_sum + + IMPLICIT NONE + PRIVATE + + PUBLIC sbc_isf, sbc_isf_init, sbc_isf_div, sbc_isf_alloc ! routine called in sbcmod and divhor + + ! public in order to be able to output then + + REAL(wp), PUBLIC :: rn_hisf_tbl !: thickness of top boundary layer [m] + INTEGER , PUBLIC :: nn_isf !: flag to choose between explicit/param/specified + INTEGER , PUBLIC :: nn_isfblk !: flag to choose the bulk formulation to compute the ice shelf melting + INTEGER , PUBLIC :: nn_gammablk !: flag to choose how the exchange coefficient is computed + REAL(wp), PUBLIC :: rn_gammat0 !: temperature exchange coeficient [] + REAL(wp), PUBLIC :: rn_gammas0 !: salinity exchange coeficient [] + + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: misfkt , misfkb !: Level of ice shelf base + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rzisf_tbl !: depth of calving front (shallowest point) nn_isf ==2/3 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: rhisf_tbl, rhisf_tbl_0 !: thickness of tbl [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: r1_hisf_tbl !: 1/thickness of tbl + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ralpha !: proportion of bottom cell influenced by tbl + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: risfLeff !: effective length (Leff) BG03 nn_isf==2 + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ttbl, stbl, utbl, vtbl !: top boundary layer variable at T point + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: qisf !: net heat flux from ice shelf [W/m2] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: risf_tsc_b, risf_tsc !: before and now T & S isf contents [K.m/s & PSU.m/s] + + LOGICAL, PUBLIC :: l_isfcpl = .false. !: isf recieved from oasis + + REAL(wp), PUBLIC, SAVE :: rcpisf = 2000.0_wp !: specific heat of ice shelf [J/kg/K] + REAL(wp), PUBLIC, SAVE :: rkappa = 1.54e-6_wp !: heat diffusivity through the ice-shelf [m2/s] + REAL(wp), PUBLIC, SAVE :: rhoisf = 920.0_wp !: volumic mass of ice shelf [kg/m3] + REAL(wp), PUBLIC, SAVE :: tsurf = -20.0_wp !: air temperature on top of ice shelf [C] + REAL(wp), PUBLIC, SAVE :: rLfusisf = 0.334e6_wp !: latent heat of fusion of ice shelf [J/kg] + +!: Variable used in fldread to read the forcing file (nn_isf == 4 .OR. nn_isf == 3) + CHARACTER(len=100), PUBLIC :: cn_dirisf = './' !: Root directory for location of ssr files + TYPE(FLD_N) , PUBLIC :: sn_fwfisf !: information about the isf melting file to be read + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_fwfisf + TYPE(FLD_N) , PUBLIC :: sn_rnfisf !: information about the isf melting param. file to be read + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_rnfisf + TYPE(FLD_N) , PUBLIC :: sn_depmax_isf !: information about the grounding line depth file to be read + TYPE(FLD_N) , PUBLIC :: sn_depmin_isf !: information about the calving line depth file to be read + TYPE(FLD_N) , PUBLIC :: sn_Leff_isf !: information about the effective length file to be read + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_isf( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_isf *** + !! + !! ** Purpose : Compute Salt and Heat fluxes related to ice_shelf + !! melting and freezing + !! + !! ** Method : 4 parameterizations are available according to nn_isf + !! nn_isf = 1 : Realistic ice_shelf formulation + !! 2 : Beckmann & Goose parameterization + !! 3 : Specified runoff in deptht (Mathiot & al. ) + !! 4 : specified fwf and heat flux forcing beneath the ice shelf + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ji, jj, jk ! loop index + INTEGER :: ikt, ikb ! local integers + REAL(wp), DIMENSION(jpi,jpj) :: zt_frz, zdep ! freezing temperature (zt_frz) at depth (zdep) + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zqhcisf2d + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zfwfisf3d, zqhcisf3d, zqlatisf3d + !!--------------------------------------------------------------------- + ! + IF( MOD( kt-1, nn_fsbc) == 0 ) THEN ! compute salt and heat flux + ! + SELECT CASE ( nn_isf ) + CASE ( 1 ) ! realistic ice shelf formulation + ! compute T/S/U/V for the top boundary layer + CALL sbc_isf_tbl(tsn(:,:,:,jp_tem),ttbl(:,:),'T') + CALL sbc_isf_tbl(tsn(:,:,:,jp_sal),stbl(:,:),'T') + CALL sbc_isf_tbl(un(:,:,:) ,utbl(:,:),'U') + CALL sbc_isf_tbl(vn(:,:,:) ,vtbl(:,:),'V') + ! iom print + CALL iom_put('ttbl',ttbl(:,:)) + CALL iom_put('stbl',stbl(:,:)) + CALL iom_put('utbl',utbl(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)) + CALL iom_put('vtbl',vtbl(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:)) + ! compute fwf and heat flux + ! compute fwf and heat flux + IF( .NOT.l_isfcpl ) THEN ; CALL sbc_isf_cav (kt) + ELSE ; qisf(:,:) = fwfisf(:,:) * rLfusisf ! heat flux + ENDIF + ! + CASE ( 2 ) ! Beckmann and Goosse parametrisation + stbl(:,:) = soce + CALL sbc_isf_bg03(kt) + ! + CASE ( 3 ) ! specified runoff in depth (Mathiot et al., XXXX in preparation) + ! specified runoff in depth (Mathiot et al., XXXX in preparation) + IF( .NOT.l_isfcpl ) THEN + CALL fld_read ( kt, nn_fsbc, sf_rnfisf ) + fwfisf(:,:) = - sf_rnfisf(1)%fnow(:,:,1) ! fresh water flux from the isf (fwfisf <0 mean melting) + ENDIF + qisf(:,:) = fwfisf(:,:) * rLfusisf ! heat flux + stbl(:,:) = soce + ! + CASE ( 4 ) ! specified fwf and heat flux forcing beneath the ice shelf + ! ! specified fwf and heat flux forcing beneath the ice shelf + IF( .NOT.l_isfcpl ) THEN + CALL fld_read ( kt, nn_fsbc, sf_fwfisf ) + !CALL fld_read ( kt, nn_fsbc, sf_qisf ) + fwfisf(:,:) = -sf_fwfisf(1)%fnow(:,:,1) ! fwf + ENDIF + qisf(:,:) = fwfisf(:,:) * rLfusisf ! heat flux + stbl(:,:) = soce + ! + END SELECT + + ! compute tsc due to isf + ! isf melting implemented as a volume flux and we assume that melt water is at 0 PSU. + ! WARNING water add at temp = 0C, need to add a correction term (fwfisf * tfreez / rau0). + ! compute freezing point beneath ice shelf (or top cell if nn_isf = 3) + DO jj = 1,jpj + DO ji = 1,jpi + zdep(ji,jj)=gdepw_n(ji,jj,misfkt(ji,jj)) + END DO + END DO + CALL eos_fzp( stbl(:,:), zt_frz(:,:), zdep(:,:) ) + + risf_tsc(:,:,jp_tem) = qisf(:,:) * r1_rau0_rcp - fwfisf(:,:) * zt_frz(:,:) * r1_rau0 ! + risf_tsc(:,:,jp_sal) = 0.0_wp + + ! lbclnk + CALL lbc_lnk_multi( 'sbcisf', risf_tsc(:,:,jp_tem), 'T', 1., risf_tsc(:,:,jp_sal), 'T', 1., fwfisf,'T', 1., qisf, 'T', 1.) + ! output + IF( iom_use('iceshelf_cea') ) CALL iom_put( 'iceshelf_cea', -fwfisf(:,:) ) ! isf mass flux + IF( iom_use('hflx_isf_cea') ) CALL iom_put( 'hflx_isf_cea', risf_tsc(:,:,jp_tem) * rau0 * rcp ) ! isf sensible+latent heat (W/m2) + IF( iom_use('qlatisf' ) ) CALL iom_put( 'qlatisf' , qisf(:,:) ) ! isf latent heat + IF( iom_use('fwfisf' ) ) CALL iom_put( 'fwfisf' , fwfisf(:,:) ) ! isf mass flux (opposite sign) + + ! Diagnostics + IF( iom_use('fwfisf3d') .OR. iom_use('qlatisf3d') .OR. iom_use('qhcisf3d') .OR. iom_use('qhcisf')) THEN + ALLOCATE( zfwfisf3d(jpi,jpj,jpk) , zqhcisf3d(jpi,jpj,jpk) , zqlatisf3d(jpi,jpj,jpk) ) + ALLOCATE( zqhcisf2d(jpi,jpj) ) + ! + zfwfisf3d (:,:,:) = 0._wp ! 3d ice shelf melting (kg/m2/s) + zqhcisf3d (:,:,:) = 0._wp ! 3d heat content flux (W/m2) + zqlatisf3d(:,:,:) = 0._wp ! 3d ice shelf melting latent heat flux (W/m2) + zqhcisf2d (:,:) = fwfisf(:,:) * zt_frz * rcp ! 2d heat content flux (W/m2) + ! + DO jj = 1,jpj + DO ji = 1,jpi + ikt = misfkt(ji,jj) + ikb = misfkb(ji,jj) + DO jk = ikt, ikb - 1 + zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf (ji,jj) * r1_hisf_tbl(ji,jj) * e3t_n(ji,jj,jk) + zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * r1_hisf_tbl(ji,jj) * e3t_n(ji,jj,jk) + zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf (ji,jj) * r1_hisf_tbl(ji,jj) * e3t_n(ji,jj,jk) + END DO + zfwfisf3d (ji,jj,jk) = zfwfisf3d (ji,jj,jk) + fwfisf (ji,jj) * r1_hisf_tbl(ji,jj) & + & * ralpha(ji,jj) * e3t_n(ji,jj,jk) + zqhcisf3d (ji,jj,jk) = zqhcisf3d (ji,jj,jk) + zqhcisf2d(ji,jj) * r1_hisf_tbl(ji,jj) & + & * ralpha(ji,jj) * e3t_n(ji,jj,jk) + zqlatisf3d(ji,jj,jk) = zqlatisf3d(ji,jj,jk) + qisf (ji,jj) * r1_hisf_tbl(ji,jj) & + & * ralpha(ji,jj) * e3t_n(ji,jj,jk) + END DO + END DO + ! + CALL iom_put('fwfisf3d' , zfwfisf3d (:,:,:)) + CALL iom_put('qlatisf3d', zqlatisf3d(:,:,:)) + CALL iom_put('qhcisf3d' , zqhcisf3d (:,:,:)) + CALL iom_put('qhcisf' , zqhcisf2d (:,: )) + ! + DEALLOCATE( zfwfisf3d, zqhcisf3d, zqlatisf3d ) + DEALLOCATE( zqhcisf2d ) + ENDIF + ! + ENDIF + + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + IF( ln_rstart .AND. & ! Restart: read in restart file + & iom_varid( numror, 'fwf_isf_b', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' nit000-1 isf tracer content forcing fields read in the restart file' + CALL iom_get( numror, jpdom_autoglo, 'fwf_isf_b', fwfisf_b(:,:) , ldxios = lrxios ) ! before salt content isf_tsc trend + CALL iom_get( numror, jpdom_autoglo, 'isf_sc_b' , risf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content isf_tsc trend + CALL iom_get( numror, jpdom_autoglo, 'isf_hc_b' , risf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before salt content isf_tsc trend + ELSE + fwfisf_b(:,:) = fwfisf(:,:) + risf_tsc_b(:,:,:)= risf_tsc(:,:,:) + ENDIF + ENDIF + ! + IF( lrst_oce ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc : isf surface tracer content forcing fields written in ocean restart file ', & + & 'at it= ', kt,' date= ', ndastp + IF(lwp) WRITE(numout,*) '~~~~' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'fwf_isf_b', fwfisf(:,:) , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'isf_hc_b' , risf_tsc(:,:,jp_tem), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'isf_sc_b' , risf_tsc(:,:,jp_sal), ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + END SUBROUTINE sbc_isf + + + INTEGER FUNCTION sbc_isf_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION sbc_isf_rnf_alloc *** + !!---------------------------------------------------------------------- + sbc_isf_alloc = 0 ! set to zero if no array to be allocated + IF( .NOT. ALLOCATED( qisf ) ) THEN + ALLOCATE( risf_tsc(jpi,jpj,jpts), risf_tsc_b(jpi,jpj,jpts), qisf(jpi,jpj) , & + & rhisf_tbl(jpi,jpj) , r1_hisf_tbl(jpi,jpj), rzisf_tbl(jpi,jpj) , & + & ttbl(jpi,jpj) , stbl(jpi,jpj) , utbl(jpi,jpj) , & + & vtbl(jpi, jpj) , risfLeff(jpi,jpj) , rhisf_tbl_0(jpi,jpj), & + & ralpha(jpi,jpj) , misfkt(jpi,jpj) , misfkb(jpi,jpj) , & + & STAT= sbc_isf_alloc ) + ! + CALL mpp_sum ( 'sbcisf', sbc_isf_alloc ) + IF( sbc_isf_alloc /= 0 ) CALL ctl_stop( 'STOP', 'sbc_isf_alloc: failed to allocate arrays.' ) + ! + ENDIF + END FUNCTION + + + SUBROUTINE sbc_isf_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_isf_init *** + !! + !! ** Purpose : Initialisation of variables for iceshelf fluxes formulation + !! + !! ** Method : 4 parameterizations are available according to nn_isf + !! nn_isf = 1 : Realistic ice_shelf formulation + !! 2 : Beckmann & Goose parameterization + !! 3 : Specified runoff in deptht (Mathiot & al. ) + !! 4 : specified fwf and heat flux forcing beneath the ice shelf + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! loop index + INTEGER :: ik ! current level index + INTEGER :: ikt, ikb ! top and bottom level of the isf boundary layer + INTEGER :: inum, ierror + INTEGER :: ios ! Local integer output status for namelist read + REAL(wp) :: zhk + CHARACTER(len=256) :: cvarzisf, cvarhisf ! name for isf file + CHARACTER(LEN=32 ) :: cvarLeff ! variable name for efficient Length scale + !!---------------------------------------------------------------------- + NAMELIST/namsbc_isf/ nn_isfblk, rn_hisf_tbl, rn_gammat0, rn_gammas0, nn_gammablk, nn_isf, & + & sn_fwfisf, sn_rnfisf, sn_depmax_isf, sn_depmin_isf, sn_Leff_isf + !!---------------------------------------------------------------------- + + REWIND( numnam_ref ) ! Namelist namsbc_rnf in reference namelist : Runoffs + READ ( numnam_ref, namsbc_isf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_isf in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_rnf in configuration namelist : Runoffs + READ ( numnam_cfg, namsbc_isf, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namsbc_isf in configuration namelist' ) + IF(lwm) WRITE ( numond, namsbc_isf ) + + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'sbc_isf_init : heat flux of the ice shelf' + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~' + IF(lwp) WRITE(numout,*) ' Namelist namsbc_isf :' + IF(lwp) WRITE(numout,*) ' type ice shelf melting/freezing nn_isf = ', nn_isf + IF(lwp) WRITE(numout,*) ' bulk formulation (nn_isf=1 only) nn_isfblk = ', nn_isfblk + IF(lwp) WRITE(numout,*) ' thickness of the top boundary layer rn_hisf_tbl = ', rn_hisf_tbl + IF(lwp) WRITE(numout,*) ' gamma formulation nn_gammablk = ', nn_gammablk + IF(lwp) WRITE(numout,*) ' gammat coefficient rn_gammat0 = ', rn_gammat0 + IF(lwp) WRITE(numout,*) ' gammas coefficient rn_gammas0 = ', rn_gammas0 + IF(lwp) WRITE(numout,*) ' top drag coef. used (from namdrg_top) rn_Cd0 = ', r_Cdmin_top + + + ! 1 = presence of ISF 2 = bg03 parametrisation + ! 3 = rnf file for isf 4 = ISF fwf specified + ! option 1 and 4 need ln_isfcav = .true. (domzgr) + ! + ! Allocate public variable + IF ( sbc_isf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_isf : unable to allocate arrays' ) + ! + ! initialisation + qisf (:,:) = 0._wp ; fwfisf (:,:) = 0._wp + risf_tsc(:,:,:) = 0._wp ; fwfisf_b(:,:) = 0._wp + ! + ! define isf tbl tickness, top and bottom indice + SELECT CASE ( nn_isf ) + CASE ( 1 ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> presence of under iceshelf seas (nn_isf = 1)' + rhisf_tbl(:,:) = rn_hisf_tbl + misfkt (:,:) = mikt(:,:) ! same indice for bg03 et cav => used in isfdiv + ! + CASE ( 2 , 3 ) + IF( .NOT.l_isfcpl ) THEN + ALLOCATE( sf_rnfisf(1), STAT=ierror ) + ALLOCATE( sf_rnfisf(1)%fnow(jpi,jpj,1), sf_rnfisf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_rnfisf, (/ sn_rnfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) + ENDIF + ! read effective lenght (BG03) + IF( nn_isf == 2 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> bg03 parametrisation (nn_isf = 2)' + CALL iom_open( sn_Leff_isf%clname, inum ) + cvarLeff = TRIM(sn_Leff_isf%clvar) + CALL iom_get( inum, jpdom_data, cvarLeff, risfLeff , 1) + CALL iom_close(inum) + ! + risfLeff = risfLeff*1000.0_wp !: convertion in m + ELSE + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> rnf file for isf (nn_isf = 3)' + ENDIF + ! read depth of the top and bottom of the isf top boundary layer (in this case, isf front depth and grounding line depth) + CALL iom_open( sn_depmax_isf%clname, inum ) + cvarhisf = TRIM(sn_depmax_isf%clvar) + CALL iom_get( inum, jpdom_data, cvarhisf, rhisf_tbl, 1) !: depth of deepest point of the ice shelf base + CALL iom_close(inum) + ! + CALL iom_open( sn_depmin_isf%clname, inum ) + cvarzisf = TRIM(sn_depmin_isf%clvar) + CALL iom_get( inum, jpdom_data, cvarzisf, rzisf_tbl, 1) !: depth of shallowest point of the ice shelves base + CALL iom_close(inum) + ! + rhisf_tbl(:,:) = rhisf_tbl(:,:) - rzisf_tbl(:,:) !: tickness isf boundary layer + + !! compute first level of the top boundary layer + DO ji = 1, jpi + DO jj = 1, jpj + ik = 2 +!!gm potential bug: use gdepw_0 not _n + DO WHILE ( ik <= mbkt(ji,jj) .AND. gdepw_n(ji,jj,ik) < rzisf_tbl(ji,jj) ) ; ik = ik + 1 ; END DO + misfkt(ji,jj) = ik-1 + END DO + END DO + ! + CASE ( 4 ) + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' ==>>> specified fresh water flux in ISF (nn_isf = 4)' + ! as in nn_isf == 1 + rhisf_tbl(:,:) = rn_hisf_tbl + misfkt (:,:) = mikt(:,:) ! same indice for bg03 et cav => used in isfdiv + ! + ! load variable used in fldread (use for temporal interpolation of isf fwf forcing) + IF( .NOT.l_isfcpl ) THEN + ALLOCATE( sf_fwfisf(1), STAT=ierror ) + ALLOCATE( sf_fwfisf(1)%fnow(jpi,jpj,1), sf_fwfisf(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_fwfisf, (/ sn_fwfisf /), cn_dirisf, 'sbc_isf_init', 'read fresh water flux isf data', 'namsbc_isf' ) + ENDIF + ! + CASE DEFAULT + CALL ctl_stop( 'sbc_isf_init: wrong value of nn_isf' ) + END SELECT + + rhisf_tbl_0(:,:) = rhisf_tbl(:,:) + + ! compute bottom level of isf tbl and thickness of tbl below the ice shelf + DO jj = 1,jpj + DO ji = 1,jpi + ikt = misfkt(ji,jj) + ikb = misfkt(ji,jj) + ! thickness of boundary layer at least the top level thickness + rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3t_n(ji,jj,ikt)) + + ! determine the deepest level influenced by the boundary layer + DO jk = ikt+1, mbkt(ji,jj) + IF( (SUM(e3t_n(ji,jj,ikt:jk-1)) < rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk + END DO + rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(e3t_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. + misfkb(ji,jj) = ikb ! last wet level of the tbl + r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) + + zhk = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) ! proportion of tbl cover by cell from ikt to ikb - 1 + ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / e3t_n(ji,jj,ikb) ! proportion of bottom cell influenced by boundary layer + END DO + END DO + + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('fwf_isf_b') + CALL iom_set_rstw_var_active('isf_hc_b') + CALL iom_set_rstw_var_active('isf_sc_b') + ENDIF + + + END SUBROUTINE sbc_isf_init + + + SUBROUTINE sbc_isf_bg03(kt) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_isf_bg03 *** + !! + !! ** Purpose : add net heat and fresh water flux from ice shelf melting + !! into the adjacent ocean + !! + !! ** Method : See reference + !! + !! ** Reference : Beckmann and Goosse (2003), "A parameterization of ice shelf-ocean + !! interaction for climate models", Ocean Modelling 5(2003) 157-170. + !! (hereafter BG) + !! History : 06-02 (C. Wang) Original code + !!---------------------------------------------------------------------- + INTEGER, INTENT ( in ) :: kt + ! + INTEGER :: ji, jj, jk ! dummy loop index + INTEGER :: ik ! current level + REAL(wp) :: zt_sum ! sum of the temperature between 200m and 600m + REAL(wp) :: zt_ave ! averaged temperature between 200m and 600m + REAL(wp) :: zt_frz ! freezing point temperature at depth z + REAL(wp) :: zpress ! pressure to compute the freezing point in depth + !!---------------------------------------------------------------------- + ! + DO ji = 1, jpi + DO jj = 1, jpj + ik = misfkt(ji,jj) + !! Initialize arrays to 0 (each step) + zt_sum = 0.e0_wp + IF ( ik > 1 ) THEN + ! 1. -----------the average temperature between 200m and 600m --------------------- + DO jk = misfkt(ji,jj),misfkb(ji,jj) + ! Calculate freezing temperature + zpress = grav*rau0*gdept_n(ji,jj,ik)*1.e-04 + CALL eos_fzp(stbl(ji,jj), zt_frz, zpress) + zt_sum = zt_sum + (tsn(ji,jj,jk,jp_tem)-zt_frz) * e3t_n(ji,jj,jk) * tmask(ji,jj,jk) ! sum temp + END DO + zt_ave = zt_sum/rhisf_tbl(ji,jj) ! calcul mean value + ! 2. ------------Net heat flux and fresh water flux due to the ice shelf + ! For those corresponding to zonal boundary + qisf(ji,jj) = - rau0 * rcp * rn_gammat0 * risfLeff(ji,jj) * e1t(ji,jj) * zt_ave & + & * r1_e1e2t(ji,jj) * tmask(ji,jj,jk) + + fwfisf(ji,jj) = qisf(ji,jj) / rLfusisf !fresh water flux kg/(m2s) + fwfisf(ji,jj) = fwfisf(ji,jj) * ( soce / stbl(ji,jj) ) + !add to salinity trend + ELSE + qisf(ji,jj) = 0._wp ; fwfisf(ji,jj) = 0._wp + END IF + END DO + END DO + ! + END SUBROUTINE sbc_isf_bg03 + + + SUBROUTINE sbc_isf_cav( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_isf_cav *** + !! + !! ** Purpose : handle surface boundary condition under ice shelf + !! + !! ** Method : - + !! + !! ** Action : utau, vtau : remain unchanged + !! taum, wndm : remain unchanged + !! qns : update heat flux below ice shelf + !! emp, emps : update freshwater flux below ice shelf + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + ! + INTEGER :: ji, jj ! dummy loop indices + INTEGER :: nit + LOGICAL :: lit + REAL(wp) :: zlamb1, zlamb2, zlamb3 + REAL(wp) :: zeps1,zeps2,zeps3,zeps4,zeps6,zeps7 + REAL(wp) :: zaqe,zbqe,zcqe,zaqer,zdis,zsfrz,zcfac + REAL(wp) :: zeps = 1.e-20_wp + REAL(wp) :: zerr + REAL(wp), DIMENSION(jpi,jpj) :: zfrz + REAL(wp), DIMENSION(jpi,jpj) :: zgammat, zgammas + REAL(wp), DIMENSION(jpi,jpj) :: zfwflx, zhtflx, zhtflx_b + !!--------------------------------------------------------------------- + ! + ! coeficient for linearisation of potential tfreez + ! Crude approximation for pressure (but commonly used) + IF ( l_useCT ) THEN ! linearisation from Jourdain et al. (2017) + zlamb1 =-0.0564_wp + zlamb2 = 0.0773_wp + zlamb3 =-7.8633e-8 * grav * rau0 + ELSE ! linearisation from table 4 (Asay-Davis et al., 2015) + zlamb1 =-0.0573_wp + zlamb2 = 0.0832_wp + zlamb3 =-7.53e-8 * grav * rau0 + ENDIF + ! + ! initialisation + zgammat(:,:) = rn_gammat0 ; zgammas (:,:) = rn_gammas0 + zhtflx (:,:) = 0.0_wp ; zhtflx_b(:,:) = 0.0_wp + zfwflx (:,:) = 0.0_wp + + ! compute ice shelf melting + nit = 1 ; lit = .TRUE. + DO WHILE ( lit ) ! maybe just a constant number of iteration as in blk_core is fine + SELECT CASE ( nn_isfblk ) + CASE ( 1 ) ! ISOMIP formulation (2 equations) for volume flux (Hunter et al., 2006) + ! Calculate freezing temperature + CALL eos_fzp( stbl(:,:), zfrz(:,:), risfdep(:,:) ) + + ! compute gammat every where (2d) + CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx) + + ! compute upward heat flux zhtflx and upward water flux zwflx + DO jj = 1, jpj + DO ji = 1, jpi + zhtflx(ji,jj) = zgammat(ji,jj)*rcp*rau0*(ttbl(ji,jj)-zfrz(ji,jj)) + zfwflx(ji,jj) = - zhtflx(ji,jj)/rLfusisf + END DO + END DO + + ! Compute heat flux and upward fresh water flux + qisf (:,:) = - zhtflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) + fwfisf(:,:) = zfwflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) + + CASE ( 2 ) ! ISOMIP+ formulation (3 equations) for volume flux (Asay-Davis et al., 2015) + ! compute gammat every where (2d) + CALL sbc_isf_gammats(zgammat, zgammas, zhtflx, zfwflx) + + ! compute upward heat flux zhtflx and upward water flux zwflx + ! Resolution of a 2d equation from equation 21, 22 and 23 to find Sb (Asay-Davis et al., 2015) + DO jj = 1, jpj + DO ji = 1, jpi + ! compute coeficient to solve the 2nd order equation + zeps1 = rcp*rau0*zgammat(ji,jj) + zeps2 = rLfusisf*rau0*zgammas(ji,jj) + zeps3 = rhoisf*rcpisf*rkappa/MAX(risfdep(ji,jj),zeps) + zeps4 = zlamb2+zlamb3*risfdep(ji,jj) + zeps6 = zeps4-ttbl(ji,jj) + zeps7 = zeps4-tsurf + zaqe = zlamb1 * (zeps1 + zeps3) + zaqer = 0.5_wp/MIN(zaqe,-zeps) + zbqe = zeps1*zeps6+zeps3*zeps7-zeps2 + zcqe = zeps2*stbl(ji,jj) + zdis = zbqe*zbqe-4.0_wp*zaqe*zcqe + + ! Presumably zdis can never be negative because gammas is very small compared to gammat + ! compute s freeze + zsfrz=(-zbqe-SQRT(zdis))*zaqer + IF ( zsfrz < 0.0_wp ) zsfrz=(-zbqe+SQRT(zdis))*zaqer + + ! compute t freeze (eq. 22) + zfrz(ji,jj)=zeps4+zlamb1*zsfrz + + ! zfwflx is upward water flux + ! zhtflx is upward heat flux (out of ocean) + ! compute the upward water and heat flux (eq. 28 and eq. 29) + zfwflx(ji,jj) = rau0 * zgammas(ji,jj) * (zsfrz-stbl(ji,jj)) / MAX(zsfrz,zeps) + zhtflx(ji,jj) = zgammat(ji,jj) * rau0 * rcp * (ttbl(ji,jj) - zfrz(ji,jj) ) + END DO + END DO + + ! compute heat and water flux + qisf (:,:) = - zhtflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) + fwfisf(:,:) = zfwflx(:,:) * (1._wp - tmask(:,:,1)) * ssmask(:,:) + + END SELECT + + ! define if we need to iterate (nn_gammablk 0/1 do not need iteration) + IF ( nn_gammablk < 2 ) THEN ; lit = .FALSE. + ELSE + ! check total number of iteration + IF (nit >= 100) THEN ; CALL ctl_stop( 'STOP', 'sbc_isf_hol99 : too many iteration ...' ) + ELSE ; nit = nit + 1 + END IF + + ! compute error between 2 iterations + ! if needed save gammat and compute zhtflx_b for next iteration + zerr = MAXVAL(ABS(zhtflx-zhtflx_b)) + IF ( zerr <= 0.01_wp ) THEN ; lit = .FALSE. + ELSE ; zhtflx_b(:,:) = zhtflx(:,:) + END IF + END IF + END DO + ! + CALL iom_put('isfgammat', zgammat) + CALL iom_put('isfgammas', zgammas) + ! + END SUBROUTINE sbc_isf_cav + + + SUBROUTINE sbc_isf_gammats(pgt, pgs, pqhisf, pqwisf ) + !!---------------------------------------------------------------------- + !! ** Purpose : compute the coefficient echange for heat flux + !! + !! ** Method : gamma assume constant or depends of u* and stability + !! + !! ** References : Holland and Jenkins, 1999, JPO, p1787-1800, eq 14 + !! Jenkins et al., 2010, JPO, p2298-2312 + !!--------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:), INTENT( out) :: pgt , pgs ! + REAL(wp), DIMENSION(:,:), INTENT(in ) :: pqhisf, pqwisf ! + ! + INTEGER :: ji, jj ! loop index + INTEGER :: ikt ! local integer + REAL(wp) :: zdku, zdkv ! U, V shear + REAL(wp) :: zPr, zSc, zRc ! Prandtl, Scmidth and Richardson 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 ! U, V at T point and friction velocity + !!--------------------------------------------------------------------- + ! + SELECT CASE ( nn_gammablk ) + CASE ( 0 ) ! gamma is constant (specified in namelist) + !! ISOMIP formulation (Hunter et al, 2006) + pgt(:,:) = rn_gammat0 + pgs(:,:) = rn_gammas0 + + CASE ( 1 ) ! gamma is assume to be proportional to u* + !! Jenkins et al., 2010, JPO, p2298-2312 + !! Adopted by Asay-Davis et al. (2015) + !! compute ustar (eq. 24) +!!gm NB use pCdU here so that it will incorporate local boost of Cd0 and log layer case : +!! zustar(:,:) = SQRT( rCdU_top(:,:) * SQRT(utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + r_ke0_top) ) +!! or better : compute ustar in zdfdrg and use it here as well as in TKE, GLS and Co +!! +!! ===>>>> GM to be done this chrismas +!! +!!gm end + zustar(:,:) = SQRT( r_Cdmin_top * (utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + r_ke0_top) ) + + !! Compute gammats + pgt(:,:) = zustar(:,:) * rn_gammat0 + pgs(:,:) = zustar(:,:) * rn_gammas0 + + CASE ( 2 ) ! gamma depends of stability of boundary layer + !! Holland and Jenkins, 1999, JPO, p1787-1800, eq 14 + !! as MOL depends of flux and flux depends of MOL, best will be iteration (TO DO) + !! compute ustar + zustar(:,:) = SQRT( r_Cdmin_top * (utbl(:,:) * utbl(:,:) + vtbl(:,:) * vtbl(:,:) + r_ke0_top) ) + + !! compute Pr and Sc number (can be improved) + zPr = 13.8_wp + zSc = 2432.0_wp + + !! compute gamma mole + 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 ji = 2, jpi + DO jj = 2, jpj + ikt = mikt(ji,jj) + + IF( zustar(ji,jj) == 0._wp ) THEN ! only for kt = 1 I think + pgt = rn_gammat0 + pgs = rn_gammas0 + ELSE + !! 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 +!!gm moreover, use Max(rn2,0) to take care of static instabilities.... + zcoef = 0.5_wp / e3w_n(ji,jj,ikt+1) + ! ! shear of horizontal velocity + zdku = zcoef * ( un(ji-1,jj ,ikt ) + un(ji,jj,ikt ) & + & -un(ji-1,jj ,ikt+1) - un(ji,jj,ikt+1) ) + zdkv = zcoef * ( vn(ji ,jj-1,ikt ) + vn(ji,jj,ikt ) & + & -vn(ji ,jj-1,ikt+1) - vn(ji,jj,ikt+1) ) + ! ! richardson number (minimum value set to zero) + zRc = rn2(ji,jj,ikt+1) / MAX( zdku*zdku + zdkv*zdkv, zeps ) + + !! compute bouyancy + zts(jp_tem) = ttbl(ji,jj) + zts(jp_sal) = stbl(ji,jj) + zdep = gdepw_n(ji,jj,ikt) + ! + CALL eos_rab( zts, zdep, zab ) + ! + !! compute length scale + zbuofdep = grav * ( zab(jp_tem) * pqhisf(ji,jj) - zab(jp_sal) * pqwisf(ji,jj) ) !!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !! compute Monin Obukov Length + ! Maximum boundary layer depth + zhmax = gdept_n(ji,jj,mbkt(ji,jj)) - gdepw_n(ji,jj,mikt(ji,jj)) -0.001_wp + ! Compute Monin obukhov length scale at the surface and Ekman depth: + 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) + zetastar = 1._wp / ( SQRT(1._wp + MAX(zxsiN * zustar(ji,jj) / ( ABS(ff_f(ji,jj)) * zmols * zRc ), 0._wp))) + + !! compute the sublayer thickness + zhnu = 5 * znu / zustar(ji,jj) + + !! compute gamma turb + zgturb = 1._wp / vkarmn * LOG(zustar(ji,jj) * zxsiN * zetastar * zetastar / ( ABS(ff_f(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 + CALL lbc_lnk_multi( 'sbcisf', pgt, 'T', 1., pgs, 'T', 1.) + END SELECT + ! + END SUBROUTINE sbc_isf_gammats + + + SUBROUTINE sbc_isf_tbl( pvarin, pvarout, cd_ptin ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE sbc_isf_tbl *** + !! + !! ** Purpose : compute mean T/S/U/V in the boundary layer at T- point + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pvarin + REAL(wp), DIMENSION(:,:) , INTENT( out) :: pvarout + CHARACTER(len=1), INTENT(in ) :: cd_ptin ! point of variable in/out + ! + INTEGER :: ji, jj, jk ! loop index + INTEGER :: ikt, ikb ! top and bottom index of the tbl + REAL(wp) :: ze3, zhk + REAL(wp), DIMENSION(jpi,jpj) :: zhisf_tbl ! thickness of the tbl + REAL(wp), DIMENSION(jpi,jpj) :: zvarout + !!---------------------------------------------------------------------- + + ! initialisation + pvarout(:,:)=0._wp + + SELECT CASE ( cd_ptin ) + CASE ( 'U' ) ! compute U in the top boundary layer at T- point + ! + zvarout(:,:)=0._wp + ! + DO jj = 1,jpj + DO ji = 1,jpi + ikt = miku(ji,jj) ; ikb = miku(ji,jj) + ! thickness of boundary layer at least the top level thickness + zhisf_tbl(ji,jj) = MAX( rhisf_tbl_0(ji,jj) , e3u_n(ji,jj,ikt) ) + + ! determine the deepest level influenced by the boundary layer + DO jk = ikt+1, mbku(ji,jj) + IF ( (SUM(e3u_n(ji,jj,ikt:jk-1)) < zhisf_tbl(ji,jj)) .AND. (umask(ji,jj,jk) == 1) ) ikb = jk + END DO + zhisf_tbl(ji,jj) = MIN(zhisf_tbl(ji,jj), SUM(e3u_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. + + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + ze3 = e3u_n(ji,jj,jk) + zvarout(ji,jj) = zvarout(ji,jj) + pvarin(ji,jj,jk) / zhisf_tbl(ji,jj) * ze3 + END DO + + ! level partially include in ice shelf boundary layer + zhk = SUM( e3u_n(ji, jj, ikt:ikb - 1)) / zhisf_tbl(ji,jj) + zvarout(ji,jj) = zvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk) + END DO + END DO + DO jj = 2, jpj + DO ji = 2, jpi +!!gm a wet-point only average should be used here !!! + pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji-1,jj)) + END DO + END DO + CALL lbc_lnk('sbcisf', pvarout,'T',-1.) + + CASE ( 'V' ) ! compute V in the top boundary layer at T- point + ! + zvarout(:,:)=0._wp + ! + DO jj = 1,jpj + DO ji = 1,jpi + ikt = mikv(ji,jj) ; ikb = mikv(ji,jj) + ! thickness of boundary layer at least the top level thickness + zhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3v_n(ji,jj,ikt)) + + ! determine the deepest level influenced by the boundary layer + DO jk = ikt+1, mbkv(ji,jj) + IF ( (SUM(e3v_n(ji,jj,ikt:jk-1)) < zhisf_tbl(ji,jj)) .AND. (vmask(ji,jj,jk) == 1) ) ikb = jk + END DO + zhisf_tbl(ji,jj) = MIN(zhisf_tbl(ji,jj), SUM(e3v_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. + + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + ze3 = e3v_n(ji,jj,jk) + zvarout(ji,jj) = zvarout(ji,jj) + pvarin(ji,jj,jk) / zhisf_tbl(ji,jj) * ze3 + END DO + + ! level partially include in ice shelf boundary layer + zhk = SUM( e3v_n(ji, jj, ikt:ikb - 1)) / zhisf_tbl(ji,jj) + zvarout(ji,jj) = zvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk) + END DO + END DO + DO jj = 2, jpj + DO ji = 2, jpi +!!gm a wet-point only average should be used here !!! + pvarout(ji,jj) = 0.5_wp * (zvarout(ji,jj) + zvarout(ji,jj-1)) + END DO + END DO + CALL lbc_lnk('sbcisf', pvarout,'T',-1.) + + CASE ( 'T' ) ! compute T in the top boundary layer at T- point + DO jj = 1,jpj + DO ji = 1,jpi + ikt = misfkt(ji,jj) + ikb = misfkb(ji,jj) + + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + ze3 = e3t_n(ji,jj,jk) + pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,jk) * r1_hisf_tbl(ji,jj) * ze3 + END DO + + ! level partially include in ice shelf boundary layer + zhk = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) + pvarout(ji,jj) = pvarout(ji,jj) + pvarin(ji,jj,ikb) * (1._wp - zhk) + END DO + END DO + END SELECT + ! + ! mask mean tbl value + pvarout(:,:) = pvarout(:,:) * ssmask(:,:) + ! + END SUBROUTINE sbc_isf_tbl + + + SUBROUTINE sbc_isf_div( phdivn ) + !!---------------------------------------------------------------------- + !! *** SUBROUTINE sbc_isf_div *** + !! + !! ** Purpose : update the horizontal divergence with the runoff inflow + !! + !! ** Method : + !! CAUTION : risf_tsc(:,:,jp_sal) is negative (outflow) increase the + !! divergence and expressed in m/s + !! + !! ** Action : phdivn decreased by the runoff inflow + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT( inout ) :: phdivn ! horizontal divergence + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikt, ikb + REAL(wp) :: zhk + REAL(wp) :: zfact ! local scalar + !!---------------------------------------------------------------------- + ! + zfact = 0.5_wp + ! + IF(.NOT.ln_linssh ) THEN ! need to re compute level distribution of isf fresh water + DO jj = 1,jpj + DO ji = 1,jpi + ikt = misfkt(ji,jj) + ikb = misfkt(ji,jj) + ! thickness of boundary layer at least the top level thickness + rhisf_tbl(ji,jj) = MAX(rhisf_tbl_0(ji,jj), e3t_n(ji,jj,ikt)) + + ! determine the deepest level influenced by the boundary layer + DO jk = ikt, mbkt(ji,jj) + IF ( (SUM(e3t_n(ji,jj,ikt:jk-1)) .LT. rhisf_tbl(ji,jj)) .AND. (tmask(ji,jj,jk) == 1) ) ikb = jk + END DO + rhisf_tbl(ji,jj) = MIN(rhisf_tbl(ji,jj), SUM(e3t_n(ji,jj,ikt:ikb))) ! limit the tbl to water thickness. + misfkb(ji,jj) = ikb ! last wet level of the tbl + r1_hisf_tbl(ji,jj) = 1._wp / rhisf_tbl(ji,jj) + + zhk = SUM( e3t_n(ji, jj, ikt:ikb - 1)) * r1_hisf_tbl(ji,jj) ! proportion of tbl cover by cell from ikt to ikb - 1 + ralpha(ji,jj) = rhisf_tbl(ji,jj) * (1._wp - zhk ) / e3t_n(ji,jj,ikb) ! proportion of bottom cell influenced by boundary layer + END DO + END DO + END IF + ! + !== ice shelf melting distributed over several levels ==! + DO jj = 1,jpj + DO ji = 1,jpi + ikt = misfkt(ji,jj) + ikb = misfkb(ji,jj) + ! level fully include in the ice shelf boundary layer + DO jk = ikt, ikb - 1 + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) + ( fwfisf(ji,jj) + fwfisf_b(ji,jj) ) & + & * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact + END DO + ! level partially include in ice shelf boundary layer + phdivn(ji,jj,ikb) = phdivn(ji,jj,ikb) + ( fwfisf(ji,jj) & + & + fwfisf_b(ji,jj) ) * r1_hisf_tbl(ji,jj) * r1_rau0 * zfact * ralpha(ji,jj) + END DO + END DO + ! + END SUBROUTINE sbc_isf_div + + !!====================================================================== +END MODULE sbcisf diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcmod.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcmod.F90 new file mode 100644 index 0000000..52430b2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcmod.F90 @@ -0,0 +1,602 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 phycst ! physical constants + 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 sbcice_if ! surface boundary condition: ice-if sea-ice model +#if defined key_si3 + USE icestp ! surface boundary condition: SI3 sea-ice model +#endif + USE sbcice_cice ! surface boundary condition: CICE sea-ice model + USE sbcisf ! surface boundary condition: ice-shelf + USE sbccpl ! surface boundary condition: coupled formulation + USE cpl_oasis3 ! OASIS routines for coupling + USE sbcssr ! surface boundary condition: sea surface restoring + USE sbcrnf ! surface boundary condition: runoffs + USE sbcapr ! surface boundary condition: atmo pressure + USE sbcisf ! surface boundary condition: ice shelf + 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 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 diurnal_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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_init + !!--------------------------------------------------------------------- + !! *** 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 :: 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_cpl , ln_mixcpl, nn_components, & + & nn_ice , ln_ice_embd, & + & ln_traqsr, ln_dm2dc , & + & ln_rnf , nn_fwb , ln_ssr , ln_isf , ln_apr_dyn , & + & ln_wave , ln_cdgw , ln_sdw , ln_tauwoc , ln_stcor , & + & ln_tauw , nn_lsm, nn_sdrift + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'sbc_init : surface boundary condition setting' + WRITE(numout,*) '~~~~~~~~ ' + ENDIF + ! + ! !** read Surface Module namelist + REWIND( numnam_ref ) !* Namelist namsbc in reference namelist : Surface boundary + READ ( numnam_ref, namsbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc in reference namelist' ) + REWIND( numnam_cfg ) !* Namelist namsbc in configuration namelist : Parameters of the run + 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 ) + ! +#if defined key_mpp_mpi + ncom_fsbc = nn_fsbc ! make nn_fsbc available for lib_mpp +#endif + ! !* overwrite namelist parameter using CPP key information +#if defined key_agrif + IF( Agrif_Root() ) THEN ! AGRIF zoom (cf r1242: possibility to run without ice in fine grid) + IF( lk_si3 ) nn_ice = 2 + IF( lk_cice ) nn_ice = 3 + ENDIF +#else + IF( lk_si3 ) nn_ice = 2 + IF( lk_cice ) nn_ice = 3 +#endif + ! +#if ! defined key_si3 + IF( nn_ice == 2 ) nn_ice = 0 ! without key key_si3 you cannot use si3... +#endif + ! + 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,*) ' 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,*) ' iceshelf formulation ln_isf = ', ln_isf + WRITE(numout,*) ' nb of iterations if land-sea-mask applied nn_lsm = ', nn_lsm + WRITE(numout,*) ' surface wave ln_wave = ', ln_wave + WRITE(numout,*) ' Stokes drift corr. to vert. velocity ln_sdw = ', ln_sdw + WRITE(numout,*) ' vertical parametrization nn_sdrift = ', nn_sdrift + WRITE(numout,*) ' wave modified ocean stress ln_tauwoc = ', ln_tauwoc + WRITE(numout,*) ' wave modified ocean stress component ln_tauw = ', ln_tauw + WRITE(numout,*) ' Stokes coriolis term ln_stcor = ', ln_stcor + WRITE(numout,*) ' neutral drag coefficient (CORE,NCAR) ln_cdgw = ', ln_cdgw + ENDIF + ! + IF( .NOT.ln_wave ) THEN + ln_sdw = .false. ; ln_cdgw = .false. ; ln_tauwoc = .false. ; ln_tauw = .false. ; ln_stcor = .false. + ENDIF + IF( ln_sdw ) THEN + IF( .NOT.(nn_sdrift==jp_breivik_2014 .OR. nn_sdrift==jp_li_2017 .OR. nn_sdrift==jp_peakfr) ) & + CALL ctl_stop( 'The chosen nn_sdrift for Stokes drift vertical velocity must be 0, 1, or 2' ) + ENDIF + ll_st_bv2014 = ( nn_sdrift==jp_breivik_2014 ) + ll_st_li2017 = ( nn_sdrift==jp_li_2017 ) + ll_st_bv_li = ( ll_st_bv2014 .OR. ll_st_li2017 ) + ll_st_peakfr = ( nn_sdrift==jp_peakfr ) + IF( ln_tauwoc .AND. ln_tauw ) & + CALL ctl_stop( 'More than one method for modifying the ocean stress has been selected ', & + '(ln_tauwoc=.true. and ln_tauw=.true.)' ) + IF( ln_tauwoc ) & + CALL ctl_warn( 'You are subtracting the wave stress to the ocean (ln_tauwoc=.true.)' ) + IF( ln_tauw ) & + CALL ctl_warn( 'The wave modified ocean stress components are used (ln_tauw=.true.) ', & + 'This will override any other specification of the ocean stress' ) + ! + IF( .NOT.ln_usr ) THEN ! the model calendar needs some specificities (except in user defined case) + IF( MOD( rday , rdt ) /= 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( rdt , 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 / OPA+SAS) + SELECT CASE( nn_components ) + CASE( jp_iam_nemo ) + IF(lwp) WRITE(numout,*) ' ==>>> NEMO configured as a single executable (i.e. including both OPA and Surface module)' + CASE( jp_iam_opa ) + IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, OPA component' + IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) + IF( ln_cpl ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_cpl = T in OPA' ) + IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) + CASE( jp_iam_sas ) + IF(lwp) WRITE(numout,*) ' ==>>> Multi executable configuration. Here, SAS component' + IF( .NOT.lk_oasis ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but key_oasis3 disabled' ) + IF( ln_mixcpl ) CALL ctl_stop( 'sbc_init : OPA-SAS coupled via OASIS, but ln_mixcpl = T in OPA' ) + 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 + CASE( 3 ) !- CICE ice model + IF( .NOT.( ln_blk .OR. ln_cpl ) ) CALL ctl_stop( 'sbc_init : CICE sea-ice model requires ln_blk or ln_cpl = T' ) + IF( lk_agrif ) CALL ctl_stop( 'sbc_init : CICE sea-ice model not currently available with AGRIF' ) + CASE DEFAULT !- not supported + END SELECT + ! + ! !** 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 ! defined key_si3 && ! defined key_cice + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop( 'sbc_init : unable to allocate sbc_ice arrays' ) +#endif + ! + IF( .NOT.ln_isf ) THEN !* No ice-shelf in the domain : allocate and set to zero + IF( sbc_isf_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'sbc_init : unable to allocate sbc_isf arrays' ) + fwfisf (:,:) = 0._wp ; risf_tsc (:,:,:) = 0._wp + fwfisf_b(:,:) = 0._wp ; risf_tsc_b(:,:,:) = 0._wp + END IF + ! + 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_opa ) fr_i(:,:) = 0._wp ! except for OPA in SAS-OPA coupled case + ENDIF + ! + sfx (:,:) = 0._wp !* salt flux due to freezing/melting + fmmflx(:,:) = 0._wp !* freezing minus melting flux + + taum(:,:) = 0._wp !* wind stress module (needed in GLS in case of reduced restart) + + ! ! Choice of the Surface Boudary Condition (set nsbc) + IF( ln_dm2dc ) THEN !* daily mean to diurnal cycle + nday_qsr = -1 ! allow initialization at the 1st call + IF( .NOT.( ln_flx .OR. ln_blk ) .AND. nn_components /= jp_iam_opa ) & + & CALL ctl_stop( 'qsr diurnal cycle from daily values requires a flux or bulk formulation' ) + ENDIF + ! !* Choice of the Surface Boudary Condition + ! (set nsbc) + ! + ll_purecpl = ln_cpl .AND. .NOT.ln_mixcpl + ll_opa = nn_components == jp_iam_opa + 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( 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_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,*) ' ==>>> OPA 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 OPA-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_opa ) nn_fsbc = cpl_freq('O_SFLX') / NINT(rdt) + IF( nn_components == jp_iam_sas ) nn_fsbc = cpl_freq('I_SFLX') / NINT(rdt) + ! + IF(lwp)THEN + WRITE(numout,*) + WRITE(numout,*)" OPA-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) * rdt ) /= 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(rdt) ) < 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 ! Sea-surface mean fields initialization + ! + IF( ln_blk ) CALL sbc_blk_init ! bulk formulae initialization + + IF( ln_ssr ) CALL sbc_ssr_init ! Sea-Surface Restoring initialization + ! + IF( ln_isf ) CALL sbc_isf_init ! Compute iceshelves + ! + CALL sbc_rnf_init ! Runof initialization + ! + IF( ln_apr_dyn ) CALL sbc_apr_init ! Atmo Pressure Forcing initialization + ! +#if defined key_si3 + IF( lk_agrif .AND. nn_ice == 0 ) THEN ! allocate ice arrays in case agrif + ice-model + no-ice in child grid + IF( sbc_ice_alloc() /= 0 ) CALL ctl_stop('STOP', 'sbc_ice_alloc : unable to allocate arrays' ) + ELSEIF( nn_ice == 2 ) THEN + CALL ice_init ! ICE initialization + ENDIF +#endif + IF( nn_ice == 3 ) CALL cice_sbc_init( nsbc ) ! CICE initialization + ! + IF( ln_wave ) CALL sbc_wave_init ! surface wave initialisation + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('utau_b') + CALL iom_set_rstw_var_active('vtau_b') + CALL iom_set_rstw_var_active('qns_b') + ! The 3D heat content due to qsr forcing is treated in traqsr + ! CALL iom_set_rstw_var_active('qsr_b') + CALL iom_set_rstw_var_active('emp_b') + CALL iom_set_rstw_var_active('sfx_b') + ENDIF + + END SUBROUTINE sbc_init + + + SUBROUTINE sbc( kt ) + !!--------------------------------------------------------------------- + !! *** 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 + ! + 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 + + !!--------------------------------------------------------------------- + ! + 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 + IF( ln_isf ) THEN + fwfisf_b (:,: ) = fwfisf (:,: ) + risf_tsc_b(:,:,:) = risf_tsc(:,:,:) + ENDIF + ! + ENDIF + ! ! ---------------------------------------- ! + ! ! forcing field computation ! + ! ! ---------------------------------------- ! + ! + ll_sas = nn_components == jp_iam_sas ! component flags + ll_opa = nn_components == jp_iam_opa + ! + IF( .NOT.ll_sas ) CALL sbc_ssm ( kt ) ! mean ocean sea surface variables (sst_m, sss_m, ssu_m, ssv_m) + IF( ln_wave ) CALL sbc_wave( kt ) ! surface waves + + ! + ! !== 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 ) ! 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 ) ! OPA-SAS coupling: SAS receiving fields from OPA + CALL sbc_blk ( kt ) ! bulk formulation for the ocean + ! + CASE( jp_purecpl ) ; CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! pure coupled formulation + CASE( jp_none ) + IF( ll_opa ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! OPA-SAS coupling: OPA receiving fields from SAS + END SELECT + ! + IF( ln_mixcpl ) CALL sbc_cpl_rcv ( kt, nn_fsbc, nn_ice ) ! forced-coupled mixed formulation after forcing + ! + IF ( ln_wave .AND. (ln_tauwoc .OR. ln_tauw) ) CALL sbc_wstress( ) ! Wind stress provided by waves + ! + ! !== Misc. Options ==! + ! + SELECT CASE( nn_ice ) ! Update heat and freshwater fluxes over sea-ice areas + CASE( 1 ) ; CALL sbc_ice_if ( kt ) ! Ice-cover climatology ("Ice-if" model) +#if defined key_si3 + CASE( 2 ) ; CALL ice_stp ( kt, nsbc ) ! SI3 ice model +#endif + CASE( 3 ) ; CALL sbc_ice_cice ( kt, nsbc ) ! CICE ice model + END SELECT + + IF( ln_icebergs ) THEN + CALL icb_stp( kt ) ! compute icebergs + ! icebergs may advect into haloes during the icb step and alter emp. + ! A lbc_lnk is necessary here to ensure restartability (#2113) + IF( .NOT. ln_passive_mode ) CALL lbc_lnk( 'sbcmod', emp, 'T', 1. ) ! ensure restartability with icebergs + ENDIF + + IF( ln_isf ) CALL sbc_isf( kt ) ! compute iceshelves + + 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 ) ! 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 .AND. (.NOT. ln_diurnal_only) ) 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. ) + IF ( ll_wd ) THEN ! If near WAD point limit the flux for now + zthscl = atanh(rn_wd_sbcfra) ! taper frac default is .999 + zwdht(:,:) = sshn(:,:) + 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. & !* Restart: read in restart file + & iom_varid( numror, 'utau_b', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' nit000-1 surface forcing fields red in the restart file' + CALL iom_get( numror, jpdom_autoglo, 'utau_b', utau_b, ldxios = lrxios ) ! before i-stress (U-point) + CALL iom_get( numror, jpdom_autoglo, 'vtau_b', vtau_b, ldxios = lrxios ) ! before j-stress (V-point) + CALL iom_get( numror, jpdom_autoglo, 'qns_b' , qns_b, ldxios = lrxios ) ! before non solar heat flux (T-point) + ! The 3D heat content due to qsr forcing is treated in traqsr + ! CALL iom_get( numror, jpdom_autoglo, 'qsr_b' , qsr_b, ldxios = lrxios ) ! before solar heat flux (T-point) + CALL iom_get( numror, jpdom_autoglo, 'emp_b', emp_b, ldxios = lrxios ) ! before freshwater flux (T-point) + ! 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_autoglo, 'sfx_b', sfx_b, ldxios = lrxios ) ! 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,*) '~~~~' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'utau_b' , utau, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'vtau_b' , vtau, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'qns_b' , qns, ldxios = lwxios ) + ! 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, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sfx_b' , sfx, ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! ! ---------------------------------------- ! + ! ! Outputs and control print ! + ! ! ---------------------------------------- ! + IF( MOD( kt-1, nn_fsbc ) == 0 ) THEN + CALL iom_put( "empmr" , emp - rnf ) ! upward water flux + CALL iom_put( "empbmr" , emp_b - rnf ) ! before upward water flux ( needed to recalculate the time evolution of ssh in offline ) + 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 + CALL iom_put( "qt" , qns + qsr ) ! total heat flux + 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(ln_ctl) 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 + fwfisf), clinfo1=' emp-rnf - : ', mask1=tmask ) + CALL prt_ctl(tab2d_1=(sfx-rnf + fwfisf), 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=tsn(:,:,:,jp_tem), clinfo1=' sst - : ', mask1=tmask, kdim=1 ) + CALL prt_ctl(tab3d_1=tsn(:,:,:,jp_sal), 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/NEMO_4.0.4_surge/src/OCE/SBC/sbcrnf.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcrnf.F90 new file mode 100644 index 0000000..6a8cc0b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcrnf.F90 @@ -0,0 +1,552 @@ +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 :: 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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + 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_rau0 + 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_rau0 + 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_rau0 + ENDIF + ! ! use runoffs salinity data + IF( ln_rnf_sal ) rnf_tsc(:,:,jp_sal) = ( sf_s_rnf(1)%fnow(:,:,1) ) * rnf(:,:) * r1_rau0 + ! ! 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) * rau0 * rcp ) ! output runoff sensible heat (W/m2) + ENDIF + ! + ! ! ---------------------------------------- ! + IF( kt == nit000 ) THEN ! set the forcing field at nit000 - 1 ! + ! ! ---------------------------------------- ! + IF( ln_rstart .AND. & !* Restart: read in restart file + & iom_varid( numror, 'rnf_b', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' nit000-1 runoff forcing fields red in the restart file', lrxios + CALL iom_get( numror, jpdom_autoglo, 'rnf_b', rnf_b, ldxios = lrxios ) ! before runoff + CALL iom_get( numror, jpdom_autoglo, 'rnf_hc_b', rnf_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content of runoff + CALL iom_get( numror, jpdom_autoglo, 'rnf_sc_b', rnf_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! 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,*) '~~~~' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_b' , rnf, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_hc_b', rnf_tsc(:,:,jp_tem), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'rnf_sc_b', rnf_tsc(:,:,jp_sal), ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + END SUBROUTINE sbc_rnf + + + SUBROUTINE sbc_rnf_div( phdivn ) + !!---------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + 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 = 1, jpj + DO ji = 1, jpi + DO jk = 1, nk_rnf(ji,jj) + phdivn(ji,jj,jk) = phdivn(ji,jj,jk) - ( rnf(ji,jj) + rnf_b(ji,jj) ) * zfact * r1_rau0 / h_rnf(ji,jj) + END DO + END DO + END DO + ELSE !* variable volume case + DO jj = 1, jpj ! update the depth over which runoffs are distributed + DO ji = 1, jpi + 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_n(ji,jj,jk) ! to the bottom of the relevant grid box + END DO + ! ! 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_rau0 / h_rnf(ji,jj) + END DO + END DO + END DO + ENDIF + ELSE !== runoff put only at the surface ==! + h_rnf (:,:) = e3t_n (:,:,1) ! update h_rnf to be depth of top box + phdivn(:,:,1) = phdivn(:,:,1) - ( rnf(:,:) + rnf_b(:,:) ) * zfact * r1_rau0 / e3t_n(:,:,1) + ENDIF + ! + END SUBROUTINE sbc_rnf_div + + + SUBROUTINE sbc_rnf_init + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_rnf_init *** + !! + !! ** Purpose : Initialisation of the runoffs if (ln_rnf=T) + !! + !! ** Method : - read the runoff namsbc_rnf namelist + !! + !! ** Action : - read parameters + !!---------------------------------------------------------------------- + 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 + ! ! ============ + ! + REWIND( numnam_ref ) + READ ( numnam_ref, namsbc_rnf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_rnf in reference namelist' ) + + REWIND( numnam_cfg ) + 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%cltype == '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_data, 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj ! set the associated depth + DO ji = 1, jpi + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) + h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(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_data, 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 = 1, jpj ! take in account min depth of ocean rn_hmin + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj ! set the associated depth + DO ji = 1, jpi + h_rnf(ji,jj) = 0._wp + DO jk = 1, nk_rnf(ji,jj) + h_rnf(ji,jj) = h_rnf(ji,jj) + e3t_n(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_n(:,:,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 + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('rnf_b') + CALL iom_set_rstw_var_active('rnf_hc_b') + CALL iom_set_rstw_var_active('rnf_sc_b') + 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)' ) TRIM( cl_rnfile ), nyear ! add year + IF( sn_cnf%cltype == 'monthly' ) WRITE(cl_rnfile, '(a,"m",i2)' ) 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_data, 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/NEMO_4.0.4_surge/src/OCE/SBC/sbcssm.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcssm.F90 new file mode 100644 index 0000000..3708d76 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcssm.F90 @@ -0,0 +1,282 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_ssm( kt ) + !!--------------------------------------------------------------------- + !! *** 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 :: ji, jj ! loop index + REAL(wp) :: zcoef, zf_sbc ! local scalar + REAL(wp), DIMENSION(jpi,jpj,jpts) :: zts + CHARACTER(len=4),SAVE :: stype + !!--------------------------------------------------------------------- + IF( kt == nit000 ) THEN + IF( ln_TEOS10 ) THEN + stype='abs' ! teos-10: using absolute salinity (sst is converted to potential temperature for the surface module) + ELSE IF( ln_EOS80 ) THEN + stype='pra' ! eos-80: using practical salinity + ELSE IF ( ln_SEOS) THEN + stype='seos' ! seos using Simplified Equation of state (sst is converted to potential temperature for the surface module) + ENDIF + ENDIF + ! + ! !* surface T-, U-, V- ocean level variables (T, S, depth, velocity) + DO jj = 1, jpj + DO ji = 1, jpi + zts(ji,jj,jp_tem) = tsn(ji,jj,mikt(ji,jj),jp_tem) + zts(ji,jj,jp_sal) = tsn(ji,jj,mikt(ji,jj),jp_sal) + END DO + END DO + ! + IF( nn_fsbc == 1 ) THEN ! Instantaneous surface fields ! + ! ! ---------------------------------------- ! + ssu_m(:,:) = ub(:,:,1) + ssv_m(:,:) = vb(:,:,1) + 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(:,:) = sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ssh_m(:,:) = sshn(:,:) + ENDIF + ! + e3t_m(:,:) = e3t_n(:,:,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 * ub(:,:,1) + ssv_m(:,:) = zcoef * vb(:,:,1) + 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 * ( sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) ) + ELSE ; ssh_m(:,:) = zcoef * sshn(:,:) + ENDIF + ! + e3t_m(:,:) = zcoef * e3t_n(:,:,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(:,:) + ub(:,:,1) + ssv_m(:,:) = ssv_m(:,:) + vb(:,:,1) + 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(:,:) + sshn(:,:) - 0.5 * ( ssh_ib(:,:) + ssh_ibb(:,:) ) + ELSE ; ssh_m(:,:) = ssh_m(:,:) + sshn(:,:) + ENDIF + ! + e3t_m(:,:) = e3t_m(:,:) + e3t_n(:,:,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 ) + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'nn_fsbc', zf_sbc, ldxios = lwxios ) ! sbc frequency + CALL iom_rstput( kt, nitrst, numrow, 'ssu_m' , ssu_m, ldxios = lwxios ) ! sea surface mean fields + CALL iom_rstput( kt, nitrst, numrow, 'ssv_m' , ssv_m, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sst_m' , sst_m, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sss_m' , sss_m, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'ssh_m' , ssh_m, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'e3t_m' , e3t_m, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'frq_m' , frq_m, ldxios = lwxios ) + ! + IF( lwxios ) CALL iom_swap( cxios_context ) + 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_pot', sst_m ) + CALL iom_put( 'sss_m_'//stype, 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 + !!---------------------------------------------------------------------- + !! *** ROUTINE sbc_ssm_init *** + !! + !! ** Purpose : Initialisation of the sbc data + !! + !! ** Action : - read parameters + !!---------------------------------------------------------------------- + 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, ldxios = lrxios ) ! sbc frequency of previous run + CALL iom_get( numror, jpdom_autoglo, 'ssu_m' , ssu_m, ldxios = lrxios ) ! sea surface mean velocity (U-point) + CALL iom_get( numror, jpdom_autoglo, 'ssv_m' , ssv_m, ldxios = lrxios ) ! " " velocity (V-point) + CALL iom_get( numror, jpdom_autoglo, 'sst_m' , sst_m, ldxios = lrxios ) ! " " temperature (T-point) + CALL iom_get( numror, jpdom_autoglo, 'sss_m' , sss_m, ldxios = lrxios ) ! " " salinity (T-point) + CALL iom_get( numror, jpdom_autoglo, 'ssh_m' , ssh_m, ldxios = lrxios ) ! " " height (T-point) + CALL iom_get( numror, jpdom_autoglo, 'e3t_m' , e3t_m, ldxios = lrxios ) ! 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_autoglo, 'frq_m' , frq_m, ldxios = lrxios ) + 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(:,:) = ub(:,:,1) + ssv_m(:,:) = vb(:,:,1) + IF( l_useCT ) THEN ; sst_m(:,:) = eos_pt_from_ct( tsn(:,:,1,jp_tem), tsn(:,:,1,jp_sal) ) + ELSE ; sst_m(:,:) = tsn(:,:,1,jp_tem) + ENDIF + sss_m(:,:) = tsn (:,:,1,jp_sal) + ssh_m(:,:) = sshn (:,:) + e3t_m(:,:) = e3t_n(:,:,1) + frq_m(:,:) = 1._wp + ! + ENDIF + ! + IF( .NOT. ln_traqsr ) fraqsr_1lev(:,:) = 1._wp ! default definition: qsr 100% in the fisrt level + ! + IF( lwxios.AND.nn_fsbc > 1 ) THEN + CALL iom_set_rstw_var_active('nn_fsbc') + CALL iom_set_rstw_var_active('ssu_m') + CALL iom_set_rstw_var_active('ssv_m') + CALL iom_set_rstw_var_active('sst_m') + CALL iom_set_rstw_var_active('sss_m') + CALL iom_set_rstw_var_active('ssh_m') + CALL iom_set_rstw_var_active('e3t_m') + CALL iom_set_rstw_var_active('frq_m') + ENDIF + + END SUBROUTINE sbc_ssm_init + + !!====================================================================== +END MODULE sbcssm diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcssr.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcssr.F90 new file mode 100644 index 0000000..0baed08 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcssr.F90 @@ -0,0 +1,256 @@ +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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ! + ! ! ========================= ! + ! + IF( nn_sstr == 1 ) THEN !* Temperature restoring term + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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., 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 + END DO + END DO + ENDIF + ! + 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 + ! + REWIND( numnam_ref ) ! Namelist namsbc_ssr in reference namelist : + READ ( numnam_ref, namsbc_ssr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_ssr in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_ssr in configuration 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/MY_SRC/sbctide.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbctide.F90 similarity index 69% rename from MY_SRC/sbctide.F90 rename to NEMO_4.0.4_surge/src/OCE/SBC/sbctide.F90 index ea6d4fe..bd04882 100644 --- a/MY_SRC/sbctide.F90 +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbctide.F90 @@ -15,9 +15,6 @@ MODULE sbctide USE iom ! xIOs server USE ioipsl ! NetCDF IPSL library USE lbclnk ! ocean lateral boundary conditions (or mpp link) - ! NB - to access love number - USE bdytides - ! END NB IMPLICIT NONE PUBLIC @@ -32,11 +29,12 @@ MODULE sbctide !!---------------------------------------------------------------------- REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_pot, phi_pot - + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: amp_load, phi_load + !!---------------------------------------------------------------------- - !! NEMO/OPA 3.5 , NEMO Consortium (2013) - !! $Id: sbctide.F90 7646 2017-02-06 09:25:03Z timgraham $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -51,13 +49,22 @@ SUBROUTINE sbc_tide( kt ) IF( nsec_day == NINT(0.5_wp * rdt) .OR. kt == nit000 ) THEN ! start a new day ! - IF( kt == nit000 ) THEN + IF( kt == nit000 )THEN ALLOCATE( amp_pot(jpi,jpj,nb_harmo), & & phi_pot(jpi,jpj,nb_harmo), pot_astro(jpi,jpj) ) + IF( ln_read_load )THEN + ALLOCATE( amp_load(jpi,jpj,nb_harmo), phi_load(jpi,jpj,nb_harmo) ) + CALL tide_init_load + ENDIF ENDIF ! - amp_pot(:,:,:) = 0._wp - phi_pot(:,:,:) = 0._wp + IF( ln_read_load )THEN + amp_pot(:,:,:) = amp_load(:,:,:) + phi_pot(:,:,:) = phi_load(:,:,:) + ELSE + amp_pot(:,:,:) = 0._wp + phi_pot(:,:,:) = 0._wp + ENDIF pot_astro(:,:) = 0._wp ! ! If the run does not start from midnight then need to initialise tides @@ -100,25 +107,17 @@ SUBROUTINE tide_init_potential !!---------------------------------------------------------------------- DO jk = 1, nb_harmo -!--- NB 11/2017 -! love number now provides in tide namelist - zcons = dn_love_number * Wave(ntide(jk))%equitide * ftide(jk) -! ORIGINAL zcons = 0.7_wp * Wave(ntide(jk))%equitide * ftide(jk) -!--- END NB + zcons = 0.7_wp * Wave(ntide(jk))%equitide * ftide(jk) DO ji = 1, jpi DO jj = 1, jpj - ztmp1 = amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) ) - ztmp2 = -amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) ) + ztmp1 = ftide(jk) * amp_pot(ji,jj,jk) * COS( phi_pot(ji,jj,jk) + v0tide(jk) + utide(jk) ) + ztmp2 = -ftide(jk) * amp_pot(ji,jj,jk) * SIN( phi_pot(ji,jj,jk) + v0tide(jk) + utide(jk) ) zlat = gphit(ji,jj)*rad !! latitude en radian zlon = glamt(ji,jj)*rad !! longitude en radian ztmp = v0tide(jk) + utide(jk) + Wave(ntide(jk))%nutide * zlon ! le potentiel est composé des effets des astres: IF ( Wave(ntide(jk))%nutide == 1 ) THEN ; zcs = zcons * SIN( 2._wp*zlat ) ELSEIF( Wave(ntide(jk))%nutide == 2 ) THEN ; zcs = zcons * COS( zlat )**2 -!--- NB 11/2017 -! Add tide potential for long period tides - ELSEIF( Wave(ntide(jk))%nutide == 0 ) THEN ; zcs = zcons * (0.5_wp-1.5_wp*SIN(zlat)**2._wp) -!--- END NB ELSE ; zcs = 0._wp ENDIF ztmp1 = ztmp1 + zcs * COS( ztmp ) @@ -133,5 +132,37 @@ SUBROUTINE tide_init_potential ! 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_data,TRIM(Wave(ntide(itide))%cname_tide)//'_z1', ztr(:,:) ) + CALL iom_get ( inum, jpdom_data,TRIM(Wave(ntide(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 + !!====================================================================== END MODULE sbctide diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/sbcwave.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/sbcwave.F90 new file mode 100644 index 0000000..7f60ead --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/sbcwave.F90 @@ -0,0 +1,520 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! sbc_stokes : calculate 3D Stokes-drift velocities + !! sbc_wave : wave data from wave model in netcdf files + !! sbc_wave_init : initialisation fo surface waves + !!---------------------------------------------------------------------- + USE phycst ! physical constants + USE oce ! ocean variables + USE sbc_oce ! Surface boundary condition: ocean fields + USE zdf_oce, ONLY : ln_zdfswm + USE bdy_oce ! open boundary condition variables + USE domvvl ! domain: variable volume layers + ! + 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_wstress ! routine called in sbcmod + 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_wfreq = .FALSE. + LOGICAL, PUBLIC :: cpl_wnum = .FALSE. + LOGICAL, PUBLIC :: cpl_tauwoc = .FALSE. + LOGICAL, PUBLIC :: cpl_tauw = .FALSE. + LOGICAL, PUBLIC :: cpl_wdrag = .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 + INTEGER :: jp_wfr ! index of wave peak frequency (1/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_tauwoc ! structure of input fields (file informations, fields read) normalized wave stress into the ocean + TYPE(FLD), ALLOCATABLE, DIMENSION(:) :: sf_tauw ! structure of input fields (file informations, fields read) ocean stress components from wave model + + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: cdn_wave !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: hsw, wmp, wnum !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: wfreq !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauoc_wave !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tauw_x, tauw_y !: + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:) :: tsd2d !: + 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(:,:,:) :: usd , vsd , wsd !: Stokes drift velocities at u-, v- & w-points, resp. + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE sbc_stokes( ) + !!--------------------------------------------------------------------- + !! *** 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 Stokes transport speed + !! - Calculate horizontal divergence + !! - Integrate the horizontal divergenze from the bottom + !! ** action + !!--------------------------------------------------------------------- + INTEGER :: jj, ji, jk ! dummy loop argument + INTEGER :: ik ! local integer + REAL(wp) :: ztransp, zfac, zsp0 + REAL(wp) :: zdepth, zsqrt_depth, zexp_depth, z_two_thirds, zsqrtpi !sqrt of pi + REAL(wp) :: zbot_u, zbot_v, zkb_u, zkb_v, zke3_u, zke3_v, zda_u, zda_v + REAL(wp) :: zstokes_psi_u_bot, zstokes_psi_v_bot + REAL(wp) :: zdep_u, zdep_v, zkh_u, zkh_v + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zk_t, zk_u, zk_v, zu0_sd, zv0_sd ! 2D workspace + REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: zstokes_psi_u_top, zstokes_psi_v_top ! 2D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ze3divh ! 3D workspace + !!--------------------------------------------------------------------- + ! + ALLOCATE( ze3divh(jpi,jpj,jpk) ) + ALLOCATE( zk_t(jpi,jpj), zk_u(jpi,jpj), zk_v(jpi,jpj), zu0_sd(jpi,jpj), zv0_sd(jpi,jpj) ) + ! + ! select parameterization for the calculation of vertical Stokes drift + ! exp. wave number at t-point + IF( ll_st_bv_li ) THEN ! (Eq. (19) in Breivik et al. (2014) ) + zfac = 2.0_wp * rpi / 16.0_wp + DO jj = 1, jpj + DO ji = 1, jpi + ! 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 = 1, jpjm1 ! exp. wave number & Stokes drift velocity at u- & v-points + DO ji = 1, jpim1 + 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 + ELSE IF( ll_st_peakfr ) THEN ! peak wave number calculated from the peak frequency received by the wave model + DO jj = 1, jpj + DO ji = 1, jpi + zk_t(ji,jj) = ( 2.0_wp * rpi * wfreq(ji,jj) ) * ( 2.0_wp * rpi * wfreq(ji,jj) ) / grav + END DO + END DO + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + 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 + ENDIF + ! + ! !== horizontal Stokes Drift 3D velocity ==! + IF( ll_st_bv2014 ) THEN + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zdep_u = 0.5_wp * ( gdept_n(ji,jj,jk) + gdept_n(ji+1,jj,jk) ) + zdep_v = 0.5_wp * ( gdept_n(ji,jj,jk) + gdept_n(ji,jj+1,jk) ) + ! + 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 + ELSE IF( ll_st_li2017 .OR. ll_st_peakfr ) THEN + ALLOCATE( zstokes_psi_u_top(jpi,jpj), zstokes_psi_v_top(jpi,jpj) ) + DO jj = 1, jpjm1 ! exp. wave number & Stokes drift velocity at u- & v-points + DO ji = 1, jpim1 + zstokes_psi_u_top(ji,jj) = 0._wp + zstokes_psi_v_top(ji,jj) = 0._wp + END DO + END DO + zsqrtpi = SQRT(rpi) + z_two_thirds = 2.0_wp / 3.0_wp + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zbot_u = ( gdepw_n(ji,jj,jk+1) + gdepw_n(ji+1,jj,jk+1) ) ! 2 * bottom depth + zbot_v = ( gdepw_n(ji,jj,jk+1) + gdepw_n(ji,jj+1,jk+1) ) ! 2 * bottom depth + zkb_u = zk_u(ji,jj) * zbot_u ! 2 * k * bottom depth + zkb_v = zk_v(ji,jj) * zbot_v ! 2 * k * bottom depth + ! + zke3_u = MAX(1.e-8_wp, 2.0_wp * zk_u(ji,jj) * e3u_n(ji,jj,jk)) ! 2k * thickness + zke3_v = MAX(1.e-8_wp, 2.0_wp * zk_v(ji,jj) * e3v_n(ji,jj,jk)) ! 2k * thickness + + ! Depth attenuation .... do u component first.. + zdepth = zkb_u + zsqrt_depth = SQRT(zdepth) + zexp_depth = EXP(-zdepth) + zstokes_psi_u_bot = 1.0_wp - zexp_depth & + & - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) & + & + 1.0_wp - (1.0_wp + zdepth)*zexp_depth ) + zda_u = ( zstokes_psi_u_bot - zstokes_psi_u_top(ji,jj) ) / zke3_u + zstokes_psi_u_top(ji,jj) = zstokes_psi_u_bot + + ! ... and then v component + zdepth =zkb_v + zsqrt_depth = SQRT(zdepth) + zexp_depth = EXP(-zdepth) + zstokes_psi_v_bot = 1.0_wp - zexp_depth & + & - z_two_thirds * ( zsqrtpi*zsqrt_depth*zdepth*ERFC(zsqrt_depth) & + & + 1.0_wp - (1.0_wp + zdepth)*zexp_depth ) + zda_v = ( zstokes_psi_v_bot - zstokes_psi_v_top(ji,jj) ) / zke3_v + zstokes_psi_v_top(ji,jj) = zstokes_psi_v_bot + ! + 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 + DEALLOCATE( zstokes_psi_u_top, zstokes_psi_v_top ) + ENDIF + + CALL lbc_lnk_multi( 'sbcwave', usd, 'U', -1., vsd, 'V', -1. ) + + ! + ! !== vertical Stokes Drift 3D velocity ==! + ! + DO jk = 1, jpkm1 ! Horizontal e3*divergence + DO jj = 2, jpj + DO ji = fs_2, jpi + ze3divh(ji,jj,jk) = ( e2u(ji ,jj) * e3u_n(ji ,jj,jk) * usd(ji ,jj,jk) & + & - e2u(ji-1,jj) * e3u_n(ji-1,jj,jk) * usd(ji-1,jj,jk) & + & + e1v(ji,jj ) * e3v_n(ji,jj ,jk) * vsd(ji,jj ,jk) & + & - e1v(ji,jj-1) * e3v_n(ji,jj-1,jk) * vsd(ji,jj-1,jk) ) * r1_e1e2t(ji,jj) + END DO + END DO + END DO + ! +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + IF( l_Westedge ) ze3divh( 2:nbghostcells+1,: ,:) = 0._wp ! west + IF( l_Eastedge ) ze3divh( nlci-nbghostcells:nlci-1,:,:) = 0._wp ! east + IF( l_Southedge ) ze3divh( :,2:nbghostcells+1 ,:) = 0._wp ! south + IF( l_Northedge ) ze3divh( :,nlcj-nbghostcells:nlcj-1,:) = 0._wp ! north + ENDIF +#endif + ! + CALL lbc_lnk( 'sbcwave', ze3divh, 'T', 1. ) + ! + 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 ) + DEALLOCATE( zk_t, zk_u, zk_v, zu0_sd, zv0_sd ) + ! + END SUBROUTINE sbc_stokes + + + SUBROUTINE sbc_wstress( ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wstress *** + !! + !! ** Purpose : Updates the ocean momentum modified by waves + !! + !! ** Method : - Calculate u,v components of stress depending on stress + !! model + !! - Calculate the stress module + !! - The wind module is not modified by waves + !! ** action + !!--------------------------------------------------------------------- + INTEGER :: jj, ji ! dummy loop argument + ! + IF( ln_tauwoc ) THEN + utau(:,:) = utau(:,:)*tauoc_wave(:,:) + vtau(:,:) = vtau(:,:)*tauoc_wave(:,:) + taum(:,:) = taum(:,:)*tauoc_wave(:,:) + ENDIF + ! + IF( ln_tauw ) THEN + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + ! Stress components at u- & v-points + utau(ji,jj) = 0.5_wp * ( tauw_x(ji,jj) + tauw_x(ji+1,jj) ) + vtau(ji,jj) = 0.5_wp * ( tauw_y(ji,jj) + tauw_y(ji,jj+1) ) + ! + ! Stress module at t points + taum(ji,jj) = SQRT( tauw_x(ji,jj)*tauw_x(ji,jj) + tauw_y(ji,jj)*tauw_y(ji,jj) ) + END DO + END DO + CALL lbc_lnk_multi( 'sbcwave', utau(:,:), 'U', -1. , vtau(:,:), 'V', -1. , taum(:,:) , 'T', -1. ) + ENDIF + ! + END SUBROUTINE sbc_wstress + + + SUBROUTINE sbc_wave( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave *** + !! + !! ** Purpose : read wave parameters from wave model in netcdf files. + !! + !! ** Method : - Read namelist namsbc_wave + !! - Read Cd_n10 fields in netcdf files + !! - Read stokes drift 2d in netcdf files + !! - Read wave number in netcdf files + !! - Compute 3d stokes drift using Breivik et al.,2014 + !! formulation + !! ** action + !!--------------------------------------------------------------------- + INTEGER, INTENT(in ) :: kt ! ocean time step + !!--------------------------------------------------------------------- + ! + 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_tauwoc .AND. .NOT. cpl_tauwoc ) THEN !== Wave induced stress ==! + CALL fld_read( kt, nn_fsbc, sf_tauwoc ) ! read wave norm stress from external forcing + tauoc_wave(:,:) = sf_tauwoc(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_tauw .AND. .NOT. cpl_tauw ) THEN !== Wave induced stress ==! + CALL fld_read( kt, nn_fsbc, sf_tauw ) ! read ocean stress components from external forcing (T grid) + tauw_x(:,:) = sf_tauw(1)%fnow(:,:,1) * tmask(:,:,1) + tauw_y(:,:) = sf_tauw(2)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + IF( ln_sdw ) 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 + 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_wfr > 0 ) wfreq(:,:) = sf_sd(jp_wfr)%fnow(:,:,1) * tmask(:,:,1) ! Peak wave frequency + 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 + CALL fld_read( kt, nn_fsbc, sf_wn ) ! read wave parameters from external forcing + wnum(:,:) = sf_wn(1)%fnow(:,:,1) * tmask(:,:,1) + ENDIF + + ! Calculate only if required fields have been read + ! In coupled wave model-NEMO case the call is done after coupling + ! + IF( ( ll_st_bv_li .AND. jp_hsw>0 .AND. jp_wmp>0 .AND. jp_usd>0 .AND. jp_vsd>0 ) .OR. & + & ( ll_st_peakfr .AND. jp_wfr>0 .AND. jp_usd>0 .AND. jp_vsd>0 ) ) CALL sbc_stokes() + ! + ENDIF + ! + END SUBROUTINE sbc_wave + + + SUBROUTINE sbc_wave_init + !!--------------------------------------------------------------------- + !! *** ROUTINE sbc_wave_init *** + !! + !! ** Purpose : read wave parameters from wave model in netcdf files. + !! + !! ** Method : - Read namelist namsbc_wave + !! - Read Cd_n10 fields in netcdf files + !! - Read stokes drift 2d in netcdf files + !! - Read wave number in netcdf files + !! - Compute 3d stokes drift using Breivik et al.,2014 + !! formulation + !! ** 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, slf_j ! array of namelist informations on the fields to read + TYPE(FLD_N) :: sn_cdg, sn_usd, sn_vsd, & + & sn_hsw, sn_wmp, sn_wfr, sn_wnum, & + & sn_tauwoc, sn_tauwx, sn_tauwy ! informations about the fields to be read + ! + NAMELIST/namsbc_wave/ sn_cdg, cn_dir, sn_usd, sn_vsd, sn_hsw, sn_wmp, sn_wfr, & + & sn_wnum, sn_tauwoc, sn_tauwx, sn_tauwy + !!--------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namsbc_wave in reference namelist : File for drag coeff. from wave model + READ ( numnam_ref, namsbc_wave, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsbc_wave in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsbc_wave in configuration namelist : File for drag coeff. from wave model + 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( ln_cdgw ) THEN + 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) ) + ENDIF + + IF( ln_tauwoc ) THEN + IF( .NOT. cpl_tauwoc ) THEN + ALLOCATE( sf_tauwoc(1), STAT=ierror ) !* allocate and fill sf_wave with sn_tauwoc + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_wave structure' ) + ! + ALLOCATE( sf_tauwoc(1)%fnow(jpi,jpj,1) ) + IF( sn_tauwoc%ln_tint ) ALLOCATE( sf_tauwoc(1)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_tauwoc, (/ sn_tauwoc /), cn_dir, 'sbc_wave_init', 'Wave module', 'namsbc_wave' ) + ENDIF + ALLOCATE( tauoc_wave(jpi,jpj) ) + ENDIF + + IF( ln_tauw ) THEN + IF( .NOT. cpl_tauw ) THEN + ALLOCATE( sf_tauw(2), STAT=ierror ) !* allocate and fill sf_wave with sn_tauwx/y + IF( ierror > 0 ) CALL ctl_stop( 'STOP', 'sbc_wave_init: unable to allocate sf_tauw structure' ) + ! + ALLOCATE( slf_j(2) ) + slf_j(1) = sn_tauwx + slf_j(2) = sn_tauwy + ALLOCATE( sf_tauw(1)%fnow(jpi,jpj,1) ) + ALLOCATE( sf_tauw(2)%fnow(jpi,jpj,1) ) + IF( slf_j(1)%ln_tint ) ALLOCATE( sf_tauw(1)%fdta(jpi,jpj,1,2) ) + IF( slf_j(2)%ln_tint ) ALLOCATE( sf_tauw(2)%fdta(jpi,jpj,1,2) ) + CALL fld_fill( sf_tauw, (/ slf_j /), cn_dir, 'sbc_wave_init', 'read wave input', 'namsbc_wave' ) + ENDIF + ALLOCATE( tauw_x(jpi,jpj) ) + ALLOCATE( tauw_y(jpi,jpj) ) + ENDIF + + IF( ln_sdw ) THEN ! 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 ; jp_wfr=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 .AND. ll_st_bv_li ) THEN + jpfld = jpfld + 1 + jp_hsw = jpfld + ENDIF + IF( .NOT. cpl_wper .AND. ll_st_bv_li ) THEN + jpfld = jpfld + 1 + jp_wmp = jpfld + ENDIF + IF( .NOT. cpl_wfreq .AND. ll_st_peakfr ) THEN + jpfld = jpfld + 1 + jp_wfr = jpfld + ENDIF + + ! 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 + IF( jp_wfr > 0 ) slf_i(jp_wfr) = sn_wfr + + 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' ) + ENDIF + ALLOCATE( usd (jpi,jpj,jpk), vsd (jpi,jpj,jpk), wsd(jpi,jpj,jpk) ) + ALLOCATE( hsw (jpi,jpj) , wmp (jpi,jpj) ) + ALLOCATE( wfreq(jpi,jpj) ) + ALLOCATE( ut0sd(jpi,jpj) , vt0sd(jpi,jpj) ) + ALLOCATE( div_sd(jpi,jpj) ) + ALLOCATE( tsd2d (jpi,jpj) ) + + ut0sd(:,:) = 0._wp + vt0sd(:,:) = 0._wp + hsw(:,:) = 0._wp + wmp(:,:) = 0._wp + + usd(:,:,:) = 0._wp + vsd(:,:,:) = 0._wp + wsd(:,:,:) = 0._wp + ! Wave number needed only if 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 toallocate sf_wave 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 + ALLOCATE( wnum(jpi,jpj) ) + ENDIF + ! + END SUBROUTINE sbc_wave_init + + !!====================================================================== +END MODULE sbcwave diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/tide.h90 b/NEMO_4.0.4_surge/src/OCE/SBC/tide.h90 new file mode 100644 index 0000000..d348c1c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/tide.h90 @@ -0,0 +1,43 @@ + !!---------------------------------------------------------------------- + !! History : 3.2 ! 2007 (O. Le Galloudec) Original code + !!---------------------------------------------------------------------- + + ! !! name_tide , equitide , nutide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! + ! !! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !! + Wave( 1) = tide( 'M2' , 0.242297 , 2 , 2 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + Wave( 2) = tide( 'N2' , 0.046313 , 2 , 2 , -3 , 2 , 1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + Wave( 3) = tide( '2N2' , 0.006184 , 2 , 2 , -4 , 2 , 2 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + Wave( 4) = tide( 'S2' , 0.113572 , 2 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + Wave( 5) = tide( 'K2' , 0.030875 , 2 , 2 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , -2 , 0 , 235 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + Wave( 6) = tide( 'K1' , 0.142408 , 1 , 1 , 0 , 1 , 0 , 0 , -90 , 0 , 0 , -1 , 0 , 0 , 227 ) + Wave( 7) = tide( 'O1' , 0.101266 , 1 , 1 , -2 , 1 , 0 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + Wave( 8) = tide( 'Q1' , 0.019387 , 1 , 1 , -3 , 1 , 1 , 0 , +90 , 2 , -1 , 0 , 0 , 0 , 75 ) + Wave( 9) = tide( 'P1' , 0.047129 , 1 , 1 , 0 , -1 , 0 , 0 , +90 , 0 , 0 , 0 , 0 , 0 , 0 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + Wave(10) = tide( 'M4' , 0.000000 , 4 , 4 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + Wave(11) = tide( 'Mf' , 0.042017 , 0 , 0 , 2 , 0 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + Wave(12) = tide( 'Mm' , 0.022191 , 0 , 0 , 1 , 0 , -1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 73 ) + Wave(13) = tide( 'Msqm' , 0.000667 , 0 , 0 , 4 , -2 , 0 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + Wave(14) = tide( 'Mtm' , 0.008049 , 0 , 0 , 3 , 0 , -1 , 0 , 0 , -2 , 0 , 0 , 0 , 0 , 74 ) + ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! + Wave(15) = tide( 'S1' , 0.000000 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + Wave(16) = tide( 'MU2' , 0.005841 , 2 , 2 , -4 , 4 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + Wave(17) = tide( 'NU2' , 0.009094 , 2 , 2 , -3 , 4 , -1 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 78 ) + Wave(18) = tide( 'L2' , 0.006694 , 2 , 2 , -1 , 2 , -1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 215 ) + Wave(19) = tide( 'T2' , 0.006614 , 2 , 2 , 0 , -1 , 0 , 1 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ) + ! + ! !! name_tide , equitide , nutide , nt , ns , nh , np , np1 , shift , nksi , nnu0 , nnu1 , nnu2 , R , formula !! + Wave(20) = tide( 'MNS2' , 0.000000 , 2 , 2 , -5 , 4 , 1 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 6 ) + Wave(21) = tide( 'Lam2' , 0.001760 , 2 , 2 , -1 , 0 , 1 , 0 , +180 , 2 , -2 , 0 , 0 , 0 , 78 ) + Wave(22) = tide( 'MSN2' , 0.000000 , 2 , 2 , 1 , 0 , 1 , 0 , 0 , 2 , -2 , 0 , 2 , 0 , 6 ) + Wave(23) = tide( '2SM2' , 0.000000 , 2 , 2 , 2 , -2 , 0 , 0 , 0 , -2 , 2 , 0 , 0 , 0 , 16 ) + Wave(24) = tide( 'MO3' , 0.000000 , 3 , 3 , -4 , 1 , 0 , 0 , +90 , 2 , -2 , 0 , 0 , 0 , 13 ) + Wave(25) = tide( 'MK3' , 0.000000 , 3 , 3 , -2 , 3 , 0 , 0 , -90 , 2 , -2 , -1 , 0 , 0 , 10 ) + Wave(26) = tide( 'MN4' , 0.000000 , 4 , 4 , -5 , 4 , 1 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 1 ) + Wave(27) = tide( 'MS4' , 0.000000 , 4 , 4 , -2 , 2 , 0 , 0 , 0 , 2 , -2 , 0 , 0 , 0 , 2 ) + Wave(28) = tide( 'M6' , 0.000000 , 6 , 6 , -6 , 6 , 0 , 0 , 0 , 6 , -6 , 0 , 0 , 0 , 4 ) + Wave(29) = tide( '2MS6' , 0.000000 , 6 , 6 , -4 , 4 , 0 , 0 , 0 , 4 , -4 , 0 , 0 , 0 , 6 ) + Wave(30) = tide( '2MK6' , 0.000000 , 6 , 6 , -4 , 6 , 0 , 0 , 0 , 4 , -4 , 0 , -2 , 0 , 5 ) + Wave(31) = tide( '3M2S2' , 0.000000 , 2 , 2 , -6 , 6 , 0 , 0 , 0 , 6 , -6 , 0 , 0 , 0 , 12 ) diff --git a/MY_SRC/tide_mod.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/tide_mod.F90 similarity index 95% rename from MY_SRC/tide_mod.F90 rename to NEMO_4.0.4_surge/src/OCE/SBC/tide_mod.F90 index d14af9b..7984371 100644 --- a/MY_SRC/tide_mod.F90 +++ b/NEMO_4.0.4_surge/src/OCE/SBC/tide_mod.F90 @@ -15,17 +15,10 @@ MODULE tide_mod PUBLIC tide_harmo ! called by tideini and diaharm modules PUBLIC tide_init_Wave ! called by tideini and diaharm modules -!--- NB - extend number of constituents for tide -# if defined key_FES14_tides - INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 34 !: maximum number of harmonic -# else - INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 19 !: maximum number of harmonic -# endif -!--- END NB - + INTEGER, PUBLIC, PARAMETER :: jpmax_harmo = 31 !: maximum number of harmonic TYPE, PUBLIC :: tide - CHARACTER(LEN=4) :: cname_tide + CHARACTER(LEN=5) :: cname_tide REAL(wp) :: equitide INTEGER :: nutide INTEGER :: nt, ns, nh, np, np1, shift @@ -40,20 +33,14 @@ MODULE tide_mod REAL(wp) :: sh_I, sh_x1ra, sh_N ! !!---------------------------------------------------------------------- - !! NEMO/OPA 3.3 , LOCEAN-IPSL (2010) - !! $Id: tide_mod.F90 5215 2015-04-15 16:11:56Z nicolasmartin $ - !! Software governed by the CeCILL licence (modipsl/doc/NEMO_CeCILL.txt) + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS SUBROUTINE tide_init_Wave -!! NB -# if defined key_FES14_tides -# include "tide_FES14.h90" -# else -!! END NB # include "tide.h90" -# endif END SUBROUTINE tide_init_Wave @@ -300,7 +287,7 @@ RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) CASE( 11 ) !== formule 11, compound waves (75 x 0) !!gm bug???? zf 2 fois ! zf = nodal_factort(75) - zf = nodal_factort( 0) + zf1 = nodal_factort( 0) zf = zf * zf1 ! CASE( 12 ) !== formule 12, compound waves (78 x 78 x 78 x 0) @@ -343,12 +330,6 @@ RECURSIVE FUNCTION nodal_factort( kformula ) RESULT( zf ) zf1 = nodal_factort( 0) zf = zf * zf1 * zf1 ! -!--- NB 11/2017 - CASE( 20 ) !== formule 20, compound waves ( 78 x 78 x 78 x 78 ) - zf1 = nodal_factort(78) - zf = zf1 * zf1 * zf1 * zf1 -!--- END NB -! CASE( 73 ) !== formule 73 zs = sin(sh_I) zf = (2./3.-zs*zs)/0.5021 diff --git a/MY_SRC/tideini.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/tideini.F90 similarity index 67% rename from MY_SRC/tideini.F90 rename to NEMO_4.0.4_surge/src/OCE/SBC/tideini.F90 index 7094de8..9962407 100644 --- a/MY_SRC/tideini.F90 +++ b/NEMO_4.0.4_surge/src/OCE/SBC/tideini.F90 @@ -7,8 +7,8 @@ MODULE tideini !!---------------------------------------------------------------------- USE oce ! ocean dynamics and tracers variables USE dom_oce ! ocean space and time domain - USE phycst ! physical constant - USE daymod ! calandar + USE phycst ! physical constants + USE daymod ! calendar USE tide_mod ! ! USE in_out_manager ! I/O units @@ -26,19 +26,21 @@ MODULE tideini LOGICAL , PUBLIC :: ln_tide !: LOGICAL , PUBLIC :: ln_tide_pot !: + LOGICAL , PUBLIC :: ln_read_load !: + LOGICAL , PUBLIC :: ln_scal_load !: LOGICAL , PUBLIC :: ln_tide_ramp !: INTEGER , PUBLIC :: nb_harmo !: INTEGER , PUBLIC :: kt_tide !: REAL(wp), PUBLIC :: rdttideramp !: - ! NB - read love number from namelist - REAL(wp), PUBLIC :: dn_love_number !: - ! END NB + REAL(wp), PUBLIC :: rn_scal_load !: + CHARACTER(lc), PUBLIC :: cn_tide_load !: + INTEGER , PUBLIC, ALLOCATABLE, DIMENSION(:) :: ntide !: !!---------------------------------------------------------------------- - !! NEMO/OPA 3.5 , NEMO Consortium (2013) - !! $Id: tideini.F90 7646 2017-02-06 09:25:03Z timgraham $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -47,40 +49,40 @@ SUBROUTINE tide_init !! *** ROUTINE tide_init *** !!---------------------------------------------------------------------- INTEGER :: ji, jk - CHARACTER(LEN=4), DIMENSION(jpmax_harmo) :: clname + CHARACTER(LEN=5), DIMENSION(jpmax_harmo) :: clname INTEGER :: ios ! Local integer output status for namelist read ! - ! NB - read love number from namelist - !NAMELIST/nam_tide/ln_tide, ln_tide_pot, ln_tide_ramp, rdttideramp, clname - NAMELIST/nam_tide/ln_tide, ln_tide_pot, ln_tide_ramp, rdttideramp, dn_love_number, clname - ! END NB + NAMELIST/nam_tide/ln_tide, ln_tide_pot, ln_scal_load, ln_read_load, cn_tide_load, & + & ln_tide_ramp, rn_scal_load, rdttideramp, clname !!---------------------------------------------------------------------- ! ! Read Namelist nam_tide REWIND( numnam_ref ) ! Namelist nam_tide in reference namelist : Tides READ ( numnam_ref, nam_tide, IOSTAT = ios, ERR = 901) -901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist', lwp ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in reference namelist' ) ! REWIND( numnam_cfg ) ! Namelist nam_tide in configuration namelist : Tides READ ( numnam_cfg, nam_tide, IOSTAT = ios, ERR = 902 ) -902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist', lwp ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_tide in configuration namelist' ) IF(lwm) WRITE ( numond, nam_tide ) ! - IF (ln_tide) THEN + 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,*) ' Apply astronomical potential : ln_tide_pot = ', ln_tide_pot -! WRITE(numout,*) ' nb_harmo = ', nb_harmo - WRITE(numout,*) ' ln_tide_ramp = ', ln_tide_ramp -! NB - Love number - WRITE(numout,*) ' dn_love_number = ', dn_love_number -! End NB + WRITE(numout,*) ' Use tidal components ln_tide = ', ln_tide + WRITE(numout,*) ' Apply astronomical potential ln_tide_pot = ', ln_tide_pot + 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 rdttideramp = ', rdttideramp 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,*) '~~~~~~~~~ ' @@ -95,11 +97,16 @@ SUBROUTINE tide_init IF( TRIM(clname(jk)) == Wave(ji)%cname_tide ) nb_harmo = nb_harmo + 1 END DO END DO - IF (ln_tide .and.lwp) WRITE(numout,*) ' nb_harmo = ', nb_harmo - + ! ! 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( 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)*rdt/rday < rdttideramp) ) & & CALL ctl_stop('rdttideramp must be lower than run duration') IF( ln_tide_ramp.AND.(rdttideramp<0.) ) & @@ -119,6 +126,8 @@ SUBROUTINE tide_init & utide (nb_harmo), ftide (nb_harmo) ) kt_tide = nit000 ! + IF (.NOT.ln_scal_load ) rn_scal_load = 0._wp + ! END SUBROUTINE tide_init !!====================================================================== diff --git a/NEMO_4.0.4_surge/src/OCE/SBC/updtide.F90 b/NEMO_4.0.4_surge/src/OCE/SBC/updtide.F90 new file mode 100644 index 0000000..11fcf05 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/SBC/updtide.F90 @@ -0,0 +1,81 @@ +MODULE updtide + !!====================================================================== + !! *** MODULE updtide *** + !! Initialization of tidal forcing + !!====================================================================== + !! History : 9.0 ! 07 (O. Le Galloudec) Original code + !!---------------------------------------------------------------------- + !! upd_tide : update tidal potential + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and tracers variables + USE dom_oce ! ocean space and time domain + USE in_out_manager ! I/O units + USE phycst ! physical constant + USE sbctide ! tide potential variable + USE tideini, ONLY: ln_tide_ramp, rdttideramp + + IMPLICIT NONE + PUBLIC + + PUBLIC upd_tide ! called in dynspg_... modules + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE upd_tide( kt, kit, kt_offset ) + !!---------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + INTEGER, INTENT(in), OPTIONAL :: kit ! external mode sub-time-step index (lk_dynspg_ts=T) + INTEGER, INTENT(in), OPTIONAL :: kt_offset ! time offset in number + ! of internal steps (lk_dynspg_ts=F) + ! of external steps (lk_dynspg_ts=T) + ! + INTEGER :: ioffset ! local integer + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp) :: zt, zramp ! local scalar + REAL(wp), DIMENSION(nb_harmo) :: zwt + !!---------------------------------------------------------------------- + ! + ! ! tide pulsation at model time step (or sub-time-step) + zt = ( kt - kt_tide ) * rdt + ! + ioffset = 0 + IF( PRESENT( kt_offset ) ) ioffset = kt_offset + ! + IF( PRESENT( kit ) ) THEN + zt = zt + ( kit + ioffset - 1 ) * rdt / REAL( nn_baro, wp ) + ELSE + zt = zt + ioffset * rdt + ENDIF + ! + zwt(:) = omega_tide(:) * zt + + pot_astro(:,:) = 0._wp ! update tidal potential (sum of all harmonics) + DO jk = 1, nb_harmo + pot_astro(:,:) = pot_astro(:,:) + amp_pot(:,:,jk) * COS( zwt(jk) + phi_pot(:,:,jk) ) + END DO + ! + IF( ln_tide_ramp ) THEN ! linear increase if asked + zt = ( kt - nit000 ) * rdt + IF( PRESENT( kit ) ) zt = zt + ( kit + ioffset -1) * rdt / REAL( nn_baro, wp ) + zramp = MIN( MAX( zt / (rdttideramp*rday) , 0._wp ) , 1._wp ) + pot_astro(:,:) = zramp * pot_astro(:,:) + ENDIF + ! + END SUBROUTINE upd_tide + + !!====================================================================== + +END MODULE updtide diff --git a/NEMO_4.0.4_surge/src/OCE/STO/stopar.F90 b/NEMO_4.0.4_surge/src/OCE/STO/stopar.F90 new file mode 100644 index 0000000..4950205 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/STO/stopar.F90 @@ -0,0 +1,915 @@ +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=1), DIMENSION(:), ALLOCATABLE :: sto2d_typ ! nature of grid point (T, U, V, W, F, I) + CHARACTER(len=1), 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !!---------------------------------------------------------------------- + ! stochastic equation of state only (for now) + NAMELIST/namsto/ 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_rststo, ln_rstseed, cn_storst_in, cn_storst_out + !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_trc, nn_sto_trc, rn_trc_stdxy, rn_trc_stdz, & + ! & rn_trc_tcor, nn_trc_ord, nn_trc_flt, rn_trc_lim + !!---------------------------------------------------------------------- + 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 + REWIND( numnam_ref ) ! Namelist namsto in reference namelist : stochastic parameterization + READ ( numnam_ref, namsto, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namsto in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namsto in configuration namelist : stochastic parameterization + 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(KIND=8) :: ziseed(4) ! RNG seeds in integer type + REAL(KIND=8) :: zrseed(4) ! RNG seeds in real type (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=10) :: clseed='seed0_0000' ! seed variable name + !!---------------------------------------------------------------------- + + 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_autoglo, clsto2d , sto2d(:,:,jsto) ) + END DO + ! 3D stochastic parameters + DO jsto = 1 , jpsto3d + WRITE(clsto3d(7:9),'(i3.3)') jsto + CALL iom_get( numstor, jpdom_autoglo, clsto3d , sto3d(:,:,:,jsto) ) + END DO + + IF (ln_rstseed) THEN + ! Get saved state of the random number generator + DO jseed = 1 , 4 + WRITE(clseed(5:5) ,'(i1.1)') jseed + WRITE(clseed(7:10),'(i4.4)') narea + CALL iom_get( numstor, clseed , 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(KIND=8) :: ziseed(4) ! RNG seeds in integer type + REAL(KIND=8) :: zrseed(4) ! RNG seeds in real type (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=10) :: clseed='seed0_0000' ! seed variable name + !!---------------------------------------------------------------------- + + 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) + DO jseed = 1 , 4 + WRITE(clseed(5:5) ,'(i1.1)') jseed + WRITE(clseed(7:10),'(i4.4)') narea + CALL iom_rstput( kt, nitrst, numstow, clseed , 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(KIND=8) :: gran ! Gaussian random number (forced KIND=8 as in kiss_gaussian) + + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 2, jpj-1 + DO ji = 2, jpi-1 + 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/NEMO_4.0.4_surge/src/OCE/STO/stopts.F90 b/NEMO_4.0.4_surge/src/OCE/STO/stopts.F90 new file mode 100644 index 0000000..b80e5c3 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/STO/stopts.F90 @@ -0,0 +1,146 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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(wp), 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._wp ) + 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 = 1, jpj + DO ji = 1, jpi + 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/NEMO_4.0.4_surge/src/OCE/STO/storng.F90 b/NEMO_4.0.4_surge/src/OCE/STO/storng.F90 new file mode 100644 index 0000000..450a42c --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/STO/storng.F90 @@ -0,0 +1,407 @@ +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 :: huge64=9223372036854775808.0 ! +1 + 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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) / huge64 ) + + 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) / huge64 + u2 = REAL(kiss(),wp) / huge64 + 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/NEMO_4.0.4_surge/src/OCE/TRA/eosbn2.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/eosbn2.F90 new file mode 100644 index 0000000..e509402 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/eosbn2.F90 @@ -0,0 +1,1704 @@ +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 + !! 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 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 + 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) :: rn_a0 = 1.6550e-1_wp ! thermal expansion coeff. + REAL(wp) :: 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE eos_insitu( pts, prd, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rau0) from + !! potential temperature and salinity using an equation of state + !! selected in the nameos namelist + !! + !! ** Method : prd(t,s,z) = ( rho(t,s,z) - rau0 ) / rau0 + !! 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 + !! rau0 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) ) / rau0 + !! 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 + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] + ! + 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('eos-insitu') + ! + SELECT CASE( neos ) + ! + CASE( np_teos10, np_eos80 ) !== polynomial TEOS-10 / EOS-80 ==! + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + ! + 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_rau0 - 1._wp ) * ztm ! density anomaly (masked) + ! + END DO + END DO + END DO + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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_rau0 * ztm ! density anomaly (masked) + END DO + END DO + END DO + ! + END SELECT + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-insitu : ', kdim=jpk ) + ! + IF( ln_timing ) CALL timing_stop('eos-insitu') + ! + END SUBROUTINE eos_insitu + + + SUBROUTINE eos_insitu_pot( pts, prd, prhop, pdep ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_pot *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rau0) 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) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prd ! in situ density [-] + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT( out) :: prhop ! potential density (surface referenced) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pdep ! depth [m] + ! + 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 ==! + ! + ! 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 = 1, jpj + DO ji = 1, jpi + ! + ! 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_rau0 - 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 = 1, jpj + DO ji = 1, jpi + ! + 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_rau0 - 1._wp ) * ztm ! density anomaly (masked) + END DO + END DO + END DO + ENDIF + + CASE( np_seos ) !== simplified EOS ==! + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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) = ( rau0 + zn ) * ztm + ! ! density anomaly (masked) + zn = zn - ( rn_a0 * rn_mu1 * zt + rn_b0 * rn_mu2 * zs ) * zh + prd(ji,jj,jk) = zn * r1_rau0 * ztm + ! + END DO + END DO + END DO + ! + END SELECT + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=prd, clinfo1=' eos-pot: ', tab3d_2=prhop, clinfo2=' pot : ', kdim=jpk ) + ! + IF( ln_timing ) CALL timing_stop('eos-pot') + ! + END SUBROUTINE eos_insitu_pot + + + SUBROUTINE eos_insitu_2d( pts, pdep, prd ) + !!---------------------------------------------------------------------- + !! *** ROUTINE eos_insitu_2d *** + !! + !! ** Purpose : Compute the in situ density (ratio rho/rau0) 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) + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpts), INTENT(in ) :: pts ! 1 : potential temperature [Celsius] + ! ! 2 : salinity [psu] + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(jpi,jpj) , 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ! + 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_rau0 - 1._wp ! unmasked in situ density anomaly + ! + END DO + END DO + ! + CALL lbc_lnk( 'eosbn2', prd, 'T', 1. ) ! Lateral boundary conditions + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ! + 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_rau0 ! unmasked in situ density anomaly + ! + END DO + END DO + ! + CALL lbc_lnk( 'eosbn2', prd, 'T', 1. ) ! Lateral boundary conditions + ! + END SELECT + ! + IF(ln_ctl) CALL prt_ctl( tab2d_1=prd, clinfo1=' eos2d: ' ) + ! + IF( ln_timing ) CALL timing_stop('eos2d') + ! + END SUBROUTINE eos_insitu_2d + + + SUBROUTINE rab_3d( pts, pab ) + !!---------------------------------------------------------------------- + !! *** 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 + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), 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 = 1, jpj + DO ji = 1, jpi + ! + zh = gdept_n(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 + ! + ! 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_rau0 * 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_rau0 * ztm + ! + END DO + END DO + END DO + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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_n(ji,jj,jk) ! 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_rau0 * ztm ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(ji,jj,jk,jp_sal) = zn * r1_rau0 * 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(ln_ctl) CALL prt_ctl( tab3d_1=pab(:,:,:,jp_tem), clinfo1=' rab_3d_t: ', & + & tab3d_2=pab(:,:,:,jp_sal), clinfo2=' rab_3d_s : ', kdim=jpk ) + ! + IF( ln_timing ) CALL timing_stop('rab_3d') + ! + END SUBROUTINE rab_3d + + + SUBROUTINE rab_2d( pts, pdep, pab ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_2d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpts) , INTENT(in ) :: pts ! pot. temperature & salinity + REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: pdep ! depth [m] + REAL(wp), DIMENSION(jpi,jpj,jpts) , 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ! + 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_rau0 + ! + ! 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_rau0 + ! + ! + END DO + END DO + ! ! Lateral boundary conditions + CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. ) + ! + CASE( np_seos ) !== simplified EOS ==! + ! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ! + 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_rau0 ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(ji,jj,jp_sal) = zn * r1_rau0 ! beta + ! + END DO + END DO + ! ! Lateral boundary conditions + CALL lbc_lnk_multi( 'eosbn2', pab(:,:,jp_tem), 'T', 1. , pab(:,:,jp_sal), 'T', 1. ) + ! + CASE DEFAULT + WRITE(ctmp1,*) ' bad flag value for neos = ', neos + CALL ctl_stop( 'rab_2d:', ctmp1 ) + ! + END SELECT + ! + IF(ln_ctl) 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 + + + SUBROUTINE rab_0d( pts, pdep, pab ) + !!---------------------------------------------------------------------- + !! *** ROUTINE rab_0d *** + !! + !! ** Purpose : Calculates thermal/haline expansion ratio for a 2d field (unmasked) + !! + !! ** Action : - pab : thermal/haline expansion ratio at T-points + !!---------------------------------------------------------------------- + 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_rau0 + ! + ! 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_rau0 + ! + ! + ! + 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_rau0 ! alpha + ! + zn = rn_b0 * ( 1._wp - rn_lambda2*zs - rn_mu2*zh ) - rn_nu*zt + pab(jp_sal) = zn * r1_rau0 ! 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 ) + !!---------------------------------------------------------------------- + !! *** 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 + !! + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pts ! pot. temperature and salinity [Celsius,psu] + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts), INTENT(in ) :: pab ! thermal/haline expansion coef. [Celsius-1,psu-1] + REAL(wp), DIMENSION(jpi,jpj,jpk ), 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 ! interior points only (2=< jk =< jpkm1 ) + DO jj = 1, jpj ! surface and bottom value set to zero one for all in istate.F90 + DO ji = 1, jpi + zrw = ( gdepw_n(ji,jj,jk ) - gdept_n(ji,jj,jk) ) & + & / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) ) + ! + 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_n(ji,jj,jk) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=pn2, clinfo1=' bn2 : ', kdim=jpk ) + ! + IF( ln_timing ) CALL timing_stop('bn2') + ! + END SUBROUTINE bn2 + + + 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 = 1, jpj + DO ji = 1, jpi + ! + zt = ctmp (ji,jj) * z1_T0 + zs = SQRT( ABS( psal(ji,jj) + zdeltaS ) * r1_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 ) + !!---------------------------------------------------------------------- + !! *** 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), DIMENSION(jpi,jpj), INTENT(in ) :: psal ! salinity [psu] + REAL(wp), DIMENSION(jpi,jpj), INTENT(in ), OPTIONAL :: pdep ! depth [m] + REAL(wp), DIMENSION(jpi,jpj), 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 = 1, jpj + DO ji = 1, jpi + 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 + + + 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 ) + !!---------------------------------------------------------------------- + !! *** 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 - rau0 gz ) / rau0 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/(rau0 gz) * dPE/dT + drd/dT = - d(pen)/dT + !! ab_pe(2) = 1/(rau0 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 + !!---------------------------------------------------------------------- + REAL(wp), 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 = 1, jpj + DO ji = 1, jpi + ! + zh = gdept_n(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 + ! + ! 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_rau0 * 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_rau0 * 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_rau0 * ztm + ! + END DO + END DO + END DO + ! + CASE( np_seos ) !== Vallis (2006) simplified EOS ==! + ! + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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_n(ji,jj,jk) ! depth in meters at t-point + ztm = tmask(ji,jj,jk) ! tmask + zn = 0.5_wp * zh * r1_rau0 * 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist nameos in reference namelist : equation of state + READ ( numnam_ref, nameos, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nameos in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist nameos in configuration namelist : equation of state + 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 ) + ! + rau0 = 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] / rau0' + 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 + ! + rau0_rcp = rau0 * rcp + r1_rau0 = 1._wp / rau0 + r1_rcp = 1._wp / rcp + r1_rau0_rcp = 1._wp / rau0_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 rau0 = ', rau0 , ' kg/m^3' + IF(lwp) WRITE(numout,*) ' 1. / rau0 r1_rau0 = ', r1_rau0, ' m^3/kg' + IF(lwp) WRITE(numout,*) ' ocean specific heat rcp = ', rcp , ' J/Kelvin' + IF(lwp) WRITE(numout,*) ' rau0 * rcp rau0_rcp = ', rau0_rcp + IF(lwp) WRITE(numout,*) ' 1. / ( rau0 * rcp ) r1_rau0_rcp = ', r1_rau0_rcp + ! + END SUBROUTINE eos_init + + !!====================================================================== +END MODULE eosbn2 diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/traadv.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traadv.F90 new file mode 100644 index 0000000..16bf501 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traadv.F90 @@ -0,0 +1,274 @@ +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 + 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 :: nadv ! choice of the type of advection scheme + ! ! associated indices: + INTEGER, PARAMETER :: np_NO_adv = 0 ! no T-S advection + INTEGER, PARAMETER :: np_CEN = 1 ! 2nd/4th order centered scheme + INTEGER, PARAMETER :: np_FCT = 2 ! 2nd/4th order Flux Corrected Transport scheme + INTEGER, PARAMETER :: np_MUS = 3 ! MUSCL scheme + INTEGER, PARAMETER :: np_UBS = 4 ! 3rd order Upstream Biased Scheme + INTEGER, PARAMETER :: np_QCK = 5 ! QUICK scheme + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_adv *** + !! + !! ** Purpose : compute the ocean tracer advection trend. + !! + !! ** Method : - Update (ua,va) with the advection term following nadv + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: jk ! dummy loop index + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zun, zvn, zwn ! 3D workspace + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_adv') + ! + ! ! set time step + IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! at nit000 (Euler) + ELSEIF( kt <= nit000 + 1 ) THEN ; r2dt = 2._wp * rdt ! at nit000 or nit000+1 (Leapfrog) + ENDIF + ! + ! !== effective transport ==! + zun(:,:,jpk) = 0._wp + zvn(:,:,jpk) = 0._wp + zwn(:,:,jpk) = 0._wp + IF( ln_wave .AND. ln_sdw ) THEN + DO jk = 1, jpkm1 ! eulerian transport + Stokes Drift + zun(:,:,jk) = e2u (:,:) * e3u_n(:,:,jk) * ( un(:,:,jk) + usd(:,:,jk) ) + zvn(:,:,jk) = e1v (:,:) * e3v_n(:,:,jk) * ( vn(:,:,jk) + vsd(:,:,jk) ) + zwn(:,:,jk) = e1e2t(:,:) * ( wn(:,:,jk) + wsd(:,:,jk) ) + END DO + ELSE + DO jk = 1, jpkm1 + zun(:,:,jk) = e2u (:,:) * e3u_n(:,:,jk) * un(:,:,jk) ! eulerian transport only + zvn(:,:,jk) = e1v (:,:) * e3v_n(:,:,jk) * vn(:,:,jk) + zwn(:,:,jk) = e1e2t(:,:) * wn(:,:,jk) + END DO + ENDIF + ! + IF( ln_vvl_ztilde .OR. ln_vvl_layer ) THEN ! add z-tilde and/or vvl corrections + zun(:,:,:) = zun(:,:,:) + un_td(:,:,:) + zvn(:,:,:) = zvn(:,:,:) + vn_td(:,:,:) + ENDIF + ! + zun(:,:,jpk) = 0._wp ! no transport trough the bottom + zvn(:,:,jpk) = 0._wp + zwn(:,:,jpk) = 0._wp + ! + IF( ln_ldfeiv .AND. .NOT. ln_traldf_triad ) & + & CALL ldf_eiv_trp( kt, nit000, zun, zvn, zwn, 'TRA' ) ! add the eiv transport (if necessary) + ! + IF( ln_mle ) CALL tra_mle_trp( kt, nit000, zun, zvn, zwn, 'TRA' ) ! add the mle transport (if necessary) + ! + CALL iom_put( "uocetr_eff", zun ) ! output effective transport + CALL iom_put( "vocetr_eff", zvn ) + CALL iom_put( "wocetr_eff", zwn ) + ! +!!gm ??? + IF( ln_diaptr ) CALL dia_ptr( zvn ) ! diagnose the effective MSF +!!gm ??? + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk), ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) + 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', zun, zvn, zwn , tsn, tsa, jpts, nn_cen_h, nn_cen_v ) + CASE ( np_FCT ) ! FCT scheme : 2nd / 4th order + CALL tra_adv_fct ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts, nn_fct_h, nn_fct_v ) + CASE ( np_MUS ) ! MUSCL + CALL tra_adv_mus ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsa, jpts , ln_mus_ups ) + CASE ( np_UBS ) ! UBS + CALL tra_adv_ubs ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts , nn_ubs_v ) + CASE ( np_QCK ) ! QUICKEST + CALL tra_adv_qck ( kt, nit000, 'TRA', r2dt, zun, zvn, zwn, tsb, tsn, tsa, jpts ) + ! + END SELECT + ! + IF( l_trdtra ) THEN ! save the advective trends for further diagnostics + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = tsa(:,:,jk,jp_tem) - ztrdt(:,:,jk) + ztrds(:,:,jk) = tsa(:,:,jk,jp_sal) - ztrds(:,:,jk) + END DO + CALL trd_tra( kt, 'TRA', jp_tem, jptra_totad, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_totad, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! ! print mean trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' adv - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + 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 ==! + REWIND( numnam_ref ) ! Namelist namtra_adv in reference namelist : Tracer advection scheme + READ ( numnam_ref, namtra_adv, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_adv in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namtra_adv in configuration namelist : Tracer advection scheme + 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 + 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/NEMO_4.0.4_surge/src/OCE/TRA/traadv_cen.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_cen.F90 new file mode 100644 index 0000000..db62711 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_cen.F90 @@ -0,0 +1,208 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_cen( kt, kit000, cdtype, pun, pvn, pwn, & + & ptn, pta, kjpt, 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 pta with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) + !!---------------------------------------------------------------------- + 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 ) :: kn_cen_h ! =2/4 (2nd or 4th order scheme) + INTEGER , INTENT(in ) :: kn_cen_v ! =2/4 (2nd or 4th order scheme) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptn ! now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + 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(jpi,jpj,jpk) :: zwx, zwy, zwz, ztu, ztv, ztw + !!---------------------------------------------------------------------- + ! + 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. ln_diaptr ) 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. + ! + ! + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj ,jk,jn) ) + zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) ) + 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 ! masked gradient + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ztu(ji,jj,jk) = ( ptn(ji+1,jj ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( ptn(ji ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'traadv_cen', ztu, 'U', -1. , ztv, 'V', -1. ) ! Lateral boundary cond. + ! + DO jk = 1, jpkm1 ! Horizontal advective fluxes + DO jj = 2, jpjm1 + DO ji = 2, fs_jpim1 ! vector opt. + zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj ,jk,jn) ! C2 interpolation of T at u- & v-points (x2) + zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) + ! ! 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 * pun(ji,jj,jk) * zC4t_u + zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * zC4t_v + END DO + END DO + END DO + CALL lbc_lnk_multi( 'traadv_cen', zwx, 'U', -1. , zwy, 'V', -1. ) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + CASE( 4 ) !* 4th order compact + CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! ztw = interpolated value of T at w-point + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zwz(ji,jj,jk) = pwn(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 = 1, jpj + DO ji = 1, jpi + zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn) + END DO + END DO + ELSE ! no ice-shelf cavities (only ocean surface) + zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn) + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 !-- Divergence of advective fluxes --! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) & + & - ( 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_n(ji,jj,jk) + END DO + END DO + END DO + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) + CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) + CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) + END IF + ! ! "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/NEMO_4.0.4_surge/src/OCE/TRA/traadv_fct.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_fct.F90 new file mode 100644 index 0000000..d23822e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_fct.F90 @@ -0,0 +1,793 @@ +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 : rau0_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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_fct( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & + & ptb, ptn, pta, kjpt, 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 pta with the now advective tracer trends + !! - send trends to trdtra module for further diagnostics (l_trdtra=T) + !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) + !!---------------------------------------------------------------------- + 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 ) :: 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 + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + 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(jpi,jpj,jpk) :: zwi, zwx, zwy, zwz, ztu, ztv, zltu, zltv, ztw + 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( 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. ln_diaptr ) 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. + ! + IF( l_trd .OR. l_hst ) THEN + ALLOCATE( ztrdx(jpi,jpj,jpk), ztrdy(jpi,jpj,jpk), ztrdz(jpi,jpj,jpk) ) + ztrdx(:,:,:) = 0._wp ; ztrdy(:,:,:) = 0._wp ; ztrdz(:,:,:) = 0._wp + ENDIF + ! + IF( l_ptr ) THEN + ALLOCATE( zptry(jpi,jpj,jpk) ) + zptry(:,:,:) = 0._wp + ENDIF + ! ! surface & bottom value : flux set to zero one for all + zwz(:,:, 1 ) = 0._wp + zwx(:,:,jpk) = 0._wp ; zwy(:,:,jpk) = 0._wp ; zwz(:,:,jpk) = 0._wp + ! + zwi(:,:,:) = 0._wp + ! + ! If adaptive vertical advection, check if it is needed on this PE at this time + IF( ln_zad_Aimp ) THEN + IF( MAXVAL( ABS( wi(:,:,:) ) ) > 0._wp ) ll_zAimp = .TRUE. + END IF + ! If active adaptive vertical advection, build tridiagonal matrix + IF( ll_zAimp ) THEN + ALLOCATE(zwdia(jpi,jpj,jpk), zwinf(jpi,jpj,jpk),zwsup(jpi,jpj,jpk)) + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. (ensure same order of calculation as below if wi=0.) + zwdia(ji,jj,jk) = 1._wp + p2dt * ( MAX( wi(ji,jj,jk ) , 0._wp ) - MIN( wi(ji,jj,jk+1) , 0._wp ) ) / e3t_a(ji,jj,jk) + zwinf(ji,jj,jk) = p2dt * MIN( wi(ji,jj,jk ) , 0._wp ) / e3t_a(ji,jj,jk) + zwsup(ji,jj,jk) = -p2dt * MAX( wi(ji,jj,jk+1) , 0._wp ) / e3t_a(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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ! upstream scheme + zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) + zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) + zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) + zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) + zwx(ji,jj,jk) = 0.5 * ( zfp_ui * ptb(ji,jj,jk,jn) + zfm_ui * ptb(ji+1,jj ,jk,jn) ) + zwy(ji,jj,jk) = 0.5 * ( zfp_vj * ptb(ji,jj,jk,jn) + zfm_vj * ptb(ji ,jj+1,jk,jn) ) + END DO + END DO + END DO + ! !* upstream tracer flux in the k direction *! + DO jk = 2, jpkm1 ! Interior value ( multiplied by wmask) + DO jj = 1, jpj + DO ji = 1, jpi + zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) + zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) + zwz(ji,jj,jk) = 0.5 * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * 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 = 1, jpj + DO ji = 1, jpi + zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface + END DO + END DO + ELSE ! no cavities: only at the ocean surface + zwz(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 !* trend and after field with monotonic scheme + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! ! 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 + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) * tmask(ji,jj,jk) + zwi(ji,jj,jk) = ( e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * ztra ) / e3t_a(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 ! Interior value ( multiplied by wmask) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t_n(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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj,jk,jn) ) - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj+1,jk,jn) ) - 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 = 1, jpjm1 ! 1st derivative (gradient) + DO ji = 1, fs_jpim1 ! vector opt. + ztu(ji,jj,jk) = ( ptn(ji+1,jj ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( ptn(ji ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END DO + END DO + DO jj = 2, jpjm1 ! 2nd derivative * 1/ 6 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + CALL lbc_lnk_multi( 'traadv_fct', zltu, 'T', 1. , zltv, 'T', 1. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO jk = 1, jpkm1 ! Horizontal advective fluxes + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj ,jk,jn) ! 2 x C2 interpolation of T at u- & v-points + zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) + ! ! C4 minus upstream advective fluxes + zwx(ji,jj,jk) = 0.5_wp * pun(ji,jj,jk) * ( zC2t_u + zltu(ji,jj,jk) - zltu(ji+1,jj,jk) ) - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * ( zC2t_v + zltv(ji,jj,jk) - zltv(ji,jj+1,jk) ) - 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 ! 1st derivative (gradient) + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + ztu(ji,jj,jk) = ( ptn(ji+1,jj ,jk,jn) - ptn(ji,jj,jk,jn) ) * umask(ji,jj,jk) + ztv(ji,jj,jk) = ( ptn(ji ,jj+1,jk,jn) - ptn(ji,jj,jk,jn) ) * vmask(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'traadv_fct', ztu, 'U', -1. , ztv, 'V', -1. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO jk = 1, jpkm1 ! Horizontal advective fluxes + DO jj = 2, jpjm1 + DO ji = 2, fs_jpim1 ! vector opt. + zC2t_u = ptn(ji,jj,jk,jn) + ptn(ji+1,jj ,jk,jn) ! 2 x C2 interpolation of T at u- & v-points (x2) + zC2t_v = ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) + ! ! 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 * pun(ji,jj,jk) * zC4t_u - zwx(ji,jj,jk) + zwy(ji,jj,jk) = 0.5_wp * pvn(ji,jj,jk) * zC4t_v - zwy(ji,jj,jk) + END DO + END DO + END DO + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zwz(ji,jj,jk) = ( pwn(ji,jj,jk) * 0.5_wp * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) & + & - zwz(ji,jj,jk) ) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + CASE( 4 ) !- 4th order COMPACT + CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! zwt = COMPACT interpolation of T at w-point + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zwz(ji,jj,jk) = ( pwn(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 ( ll_zAimp ) THEN + DO jk = 1, jpkm1 !* trend and after field with monotonic scheme + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! ! 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_a(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 ! Interior value ( multiplied by wmask) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + ! + CALL lbc_lnk_multi( 'traadv_fct', zwi, 'T', 1., zwx, 'U', -1. , zwy, 'V', -1., zwz, 'W', 1. ) + ! + ! !== monotonicity algorithm ==! + ! + CALL nonosc( ptb(:,:,:,jn), zwx, zwy, zwz, zwi, p2dt ) + ! + ! !== final trend with corrected fluxes ==! + ! + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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) + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra / e3t_n(ji,jj,jk) + zwi(ji,jj,jk) = zwi(ji,jj,jk) + p2dt * ztra / e3t_a(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 ! Interior value ( multiplied by wmask) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji ,jj ,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t_n(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, cdtype, jn, jptra_xad, ztrdx, pun, ptn(:,:,:,jn) ) + CALL trd_tra( kt, cdtype, jn, jptra_yad, ztrdy, pvn, ptn(:,:,:,jn) ) + CALL trd_tra( kt, cdtype, jn, jptra_zad, ztrdz, pwn, ptn(:,:,:,jn) ) + 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( 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 + !!---------------------------------------------------------------------- + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(in ) :: pbef, paft ! before & after field + REAL(wp), DIMENSION (jpi,jpj,jpk), INTENT(inout) :: paa, pbb, pcc ! monotonic fluxes in the 3 directions + ! + 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) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo ! - - + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zbetup, zbetdo, zbup, zbdo + !!---------------------------------------------------------------------- + ! + zbig = 1.e+40_wp + zrtrn = 1.e-15_wp + zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp + + ! Search local extrema + ! -------------------- + ! max/min of pbef & paft with large negative/positive value (-/+zbig) inside land + zbup = MAX( pbef * tmask - zbig * ( 1._wp - tmask ), & + & paft * tmask - zbig * ( 1._wp - tmask ) ) + zbdo = MIN( pbef * tmask + zbig * ( 1._wp - tmask ), & + & paft * tmask + zbig * ( 1._wp - tmask ) ) + + DO jk = 1, jpkm1 + ikm1 = MAX(jk-1,1) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + + ! 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_n(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 + CALL lbc_lnk_multi( 'traadv_fct', zbetup, 'T', 1. , zbetdo, 'T', 1. ) ! lateral boundary cond. (unchanged sign) + + ! 3. monotonic flux in the i & j direction (paa & pbb) + ! ---------------------------------------- + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 , 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 , 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 , 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 + CALL lbc_lnk_multi( 'traadv_fct', paa, 'U', -1. , pbb, 'V', -1. ) ! lateral boundary condition (changed sign) + ! + 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 !== build the three diagonal matrix ==! + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj ! first recurrence + DO ji = 1, jpi + zwt(ji,jj,2) = zwd(ji,jj,2) + END DO + END DO + DO jk = 3, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj ! second recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + DO ji = 1, jpi + pt_out(ji,jj,2) = zwrm(ji,jj,2) + END DO + END DO + DO jk = 3, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + 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 = 1, jpj ! third recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + DO ji = 1, jpi + 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 = 1, jpj + DO ji = 1, jpi + 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(wp),DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pt_in ! field at t-point + REAL(wp),DIMENSION(jpi,jpj,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(jpi,jpj,jpk) :: zwd, zwi, zws, zwrm, zwt + !!---------------------------------------------------------------------- + ! + ! !== build the three diagonal matrix & the RHS ==! + ! + DO jk = 3, jpkm1 ! interior (from jk=3 to jpk-1) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 ! 2nd order centered at top & bottom + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 + DO ji = fs_2, fs_jpim1 + zwt(ji,jj,2) = zwd(ji,jj,2) + END DO + END DO + DO jk = 3, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + DO ji = fs_2, fs_jpim1 + pt_out(ji,jj,2) = zwrm(ji,jj,2) + END DO + END DO + DO jk = 3, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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(:,:,:), INTENT(in ) :: pD, pU, PL ! 3-diagonal matrix + REAL(wp),DIMENSION(:,:,:), INTENT(in ) :: pRHS ! Right-Hand-Side + REAL(wp),DIMENSION(:,:,:), 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(jpi,jpj,jpk) :: zwt ! 3D work array + !!---------------------------------------------------------------------- + ! + kstart = 1 + klev + ! + DO jj = 2, jpjm1 !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 + DO ji = fs_2, fs_jpim1 + zwt(ji,jj,kstart) = pD(ji,jj,kstart) + END DO + END DO + DO jk = kstart+1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + DO ji = fs_2, fs_jpim1 + pt_out(ji,jj,kstart) = pRHS(ji,jj,kstart) + END DO + END DO + DO jk = kstart+1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk + DO ji = fs_2, fs_jpim1 + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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/NEMO_4.0.4_surge/src/OCE/TRA/traadv_mus.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_mus.F90 new file mode 100644 index 0000000..99eb7d9 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_mus.F90 @@ -0,0 +1,277 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_mus( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & + & ptb, pta, kjpt, 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 pta with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - htr_adv, str_adv : 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 ) :: 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 + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before tracer field + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + 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(jpi,jpj,jpk) :: zwx, zslpx ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwy, zslpy ! - - + !!---------------------------------------------------------------------- + ! + 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. ln_diaptr ) 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. + ! + 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 ! interior values + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zwx(ji,jj,jk) = umask(ji,jj,jk) * ( ptb(ji+1,jj,jk,jn) - ptb(ji,jj,jk,jn) ) + zwy(ji,jj,jk) = vmask(ji,jj,jk) * ( ptb(ji,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) + END DO + END DO + END DO + ! lateral boundary conditions (changed sign) + CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) + ! !-- Slopes of tracer + zslpx(:,:,jpk) = 0._wp ! bottom values + zslpy(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 ! interior values + DO jj = 2, jpj + DO ji = fs_2, jpi ! vector opt. + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji-1,jj ,jk) ) & + & * ( 0.25 + SIGN( 0.25, 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, zwy(ji,jj,jk) * zwy(ji ,jj-1,jk) ) ) + END DO + END DO + END DO + ! + DO jk = 1, jpkm1 !-- Slopes limitation + DO jj = 2, jpj + DO ji = fs_2, jpi ! vector opt. + zslpx(ji,jj,jk) = SIGN( 1., 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., 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 + ! + DO jk = 1, jpkm1 !-- MUSCL horizontal advective fluxes + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! MUSCL fluxes + z0u = SIGN( 0.5, pun(ji,jj,jk) ) + zalpha = 0.5 - z0u + zu = z0u - 0.5 * pun(ji,jj,jk) * p2dt * r1_e1e2u(ji,jj) / e3u_n(ji,jj,jk) + zzwx = ptb(ji+1,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji+1,jj,jk) + zzwy = ptb(ji ,jj,jk,jn) + xind(ji,jj,jk) * zu * zslpx(ji ,jj,jk) + zwx(ji,jj,jk) = pun(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + ! + z0v = SIGN( 0.5, pvn(ji,jj,jk) ) + zalpha = 0.5 - z0v + zv = z0v - 0.5 * pvn(ji,jj,jk) * p2dt * r1_e1e2v(ji,jj) / e3v_n(ji,jj,jk) + zzwx = ptb(ji,jj+1,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj+1,jk) + zzwy = ptb(ji,jj ,jk,jn) + xind(ji,jj,jk) * zv * zslpy(ji,jj ,jk) + zwy(ji,jj,jk) = pvn(ji,jj,jk) * ( zalpha * zzwx + (1.-zalpha) * zzwy ) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'traadv_mus', zwx, 'U', -1. , zwy, 'V', -1. ) ! lateral boundary conditions (changed sign) + ! + DO jk = 1, jpkm1 !-- Tracer advective trend + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji-1,jj ,jk ) & + & + zwy(ji,jj,jk) - zwy(ji ,jj-1,jk ) ) & + & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! ! trend diagnostics + IF( l_trd ) THEN + CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:,:,:,jn) ) + CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:,:,:,jn) ) + 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 ! interior values + zwx(:,:,jk) = tmask(:,:,jk) * ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) + END DO + ! !-- Slopes of tracer + zslpx(:,:,1) = 0._wp ! surface values + DO jk = 2, jpkm1 ! interior value + DO jj = 1, jpj + DO ji = 1, jpi + zslpx(ji,jj,jk) = ( zwx(ji,jj,jk) + zwx(ji,jj,jk+1) ) & + & * ( 0.25 + SIGN( 0.25, zwx(ji,jj,jk) * zwx(ji,jj,jk+1) ) ) + END DO + END DO + END DO + DO jk = 2, jpkm1 !-- Slopes limitation + DO jj = 1, jpj ! interior values + DO ji = 1, jpi + zslpx(ji,jj,jk) = SIGN( 1., 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 !-- vertical advective flux + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + z0w = SIGN( 0.5, pwn(ji,jj,jk+1) ) + zalpha = 0.5 + z0w + zw = z0w - 0.5 * pwn(ji,jj,jk+1) * p2dt * r1_e1e2t(ji,jj) / e3w_n(ji,jj,jk+1) + zzwx = ptb(ji,jj,jk+1,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk+1) + zzwy = ptb(ji,jj,jk ,jn) + xind(ji,jj,jk) * zw * zslpx(ji,jj,jk ) + zwx(ji,jj,jk+1) = pwn(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 = 1, jpj + DO ji = 1, jpi + zwx(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) + END DO + END DO + ELSE ! no cavities: only at the ocean surface + zwx(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 !-- vertical advective trend + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwx(ji,jj,jk) - zwx(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! ! send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:,:,:,jn) ) + ! + END DO ! end of tracer loop + ! + END SUBROUTINE tra_adv_mus + + !!====================================================================== +END MODULE traadv_mus diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/traadv_qck.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_qck.F90 new file mode 100644 index 0000000..1673b1b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_qck.F90 @@ -0,0 +1,458 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_qck ( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & + & ptb, ptn, pta, kjpt ) + !!---------------------------------------------------------------------- + !! *** 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 ptn + !! + !! 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 pta with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - htr_adv, str_adv : poleward advective heat and salt transport (ln_diaptr=T) + !! + !! ** Reference : Leonard (1979, 1991) + !!---------------------------------------------------------------------- + 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 + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + !!---------------------------------------------------------------------- + ! + 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. ln_diaptr ) l_ptr = .TRUE. + ! + ! + ! ! horizontal fluxes are computed with the QUICKEST + ULTIMATE scheme + CALL tra_adv_qck_i( kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt ) + CALL tra_adv_qck_j( kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt ) + + ! ! vertical fluxes are computed with the 2nd order centered scheme + CALL tra_adv_cen2_k( kt, cdtype, pwn, ptn, pta, kjpt ) + ! + END SUBROUTINE tra_adv_qck + + + SUBROUTINE tra_adv_qck_i( kt, cdtype, p2dt, pun, & + & ptb, ptn, pta, kjpt ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean 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(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun ! i-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(jpi,jpj,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 !--- Computation of the ustream and downstream value of the tracer and the mask + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zfc(ji,jj,jk) = ptb(ji-1,jj,jk,jn) ! Upstream in the x-direction for the tracer + zfd(ji,jj,jk) = ptb(ji+1,jj,jk,jn) ! Downstream in the x-direction for the tracer + END DO + END DO + END DO + CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions + + ! + ! Horizontal advective fluxes + ! --------------------------- + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) ) ! if pun > 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e1t(ji,jj) + ( 1. - zdir ) * e1t(ji+1,jj) ) * e2u(ji,jj) * e3u_n(ji,jj,jk) + zwx(ji,jj,jk) = ABS( pun(ji,jj,jk) ) * p2dt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) + zfc(ji,jj,jk) = zdir * ptb(ji ,jj,jk,jn) + ( 1. - zdir ) * ptb(ji+1,jj,jk,jn) ! FC in the x-direction for T + zfd(ji,jj,jk) = zdir * ptb(ji+1,jj,jk,jn) + ( 1. - zdir ) * ptb(ji ,jj,jk,jn) ! FD in the x-direction for T + END DO + END DO + END DO + !--- Lateral boundary conditions + CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwx(:,:,:), 'T', 1. ) + + !--- QUICKEST scheme + CALL quickest( zfu, zfd, zfc, zwx ) + ! + ! Mask at the T-points in the x-direction (mask=0 or mask=1) + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zfu(ji,jj,jk) = tmask(ji-1,jj,jk) + tmask(ji,jj,jk) + tmask(ji+1,jj,jk) - 2. + END DO + END DO + END DO + CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) ! Lateral boundary conditions + + ! + ! Tracer flux on the x-direction + DO jk = 1, jpkm1 + ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zdir = 0.5 + SIGN( 0.5, pun(ji,jj,jk) ) ! if pun > 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) * pun(ji,jj,jk) + END DO + END DO + END DO + ! + CALL lbc_lnk( 'traadv_qck', zwx(:,:,:), 'T', 1. ) ! Lateral boundary conditions + ! + ! Computation of the trend + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + ! horizontal advective trends + ztra = - zbtr * ( zwx(ji,jj,jk) - zwx(ji-1,jj,jk) ) + !--- add it to the general tracer trends + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra + END DO + END DO + END DO + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:,:,:,jn) ) + ! + END DO + ! + END SUBROUTINE tra_adv_qck_i + + + SUBROUTINE tra_adv_qck_j( kt, cdtype, p2dt, pvn, & + & ptb, ptn, pta, kjpt ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean 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(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pvn ! j-velocity components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + !! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: ztra, zbtr, zdir, zdx, zmsk ! local scalars + REAL(wp), DIMENSION(jpi,jpj,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 + ! + DO jk = 1, jpkm1 + ! + !--- Computation of the ustream and downstream value of the tracer and the mask + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! Upstream in the x-direction for the tracer + zfc(ji,jj,jk) = ptb(ji,jj-1,jk,jn) + ! Downstream in the x-direction for the tracer + zfd(ji,jj,jk) = ptb(ji,jj+1,jk,jn) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'traadv_qck', zfc(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1. ) ! Lateral boundary conditions + + + ! + ! Horizontal advective fluxes + ! --------------------------- + ! + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) ) ! if pun > 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) ) ! if pun > 0 : zdir = 1 otherwise zdir = 0 + zdx = ( zdir * e2t(ji,jj) + ( 1. - zdir ) * e2t(ji,jj+1) ) * e1v(ji,jj) * e3v_n(ji,jj,jk) + zwy(ji,jj,jk) = ABS( pvn(ji,jj,jk) ) * p2dt / zdx ! (0<zc_cfl<1 : Courant number on x-direction) + zfc(ji,jj,jk) = zdir * ptb(ji,jj ,jk,jn) + ( 1. - zdir ) * ptb(ji,jj+1,jk,jn) ! FC in the x-direction for T + zfd(ji,jj,jk) = zdir * ptb(ji,jj+1,jk,jn) + ( 1. - zdir ) * ptb(ji,jj ,jk,jn) ! FD in the x-direction for T + END DO + END DO + END DO + + !--- Lateral boundary conditions + CALL lbc_lnk_multi( 'traadv_qck', zfu(:,:,:), 'T', 1. , zfd(:,:,:), 'T', 1., zfc(:,:,:), 'T', 1., zwy(:,:,:), 'T', 1. ) + + !--- QUICKEST scheme + CALL quickest( zfu, zfd, zfc, zwy ) + ! + ! Mask at the T-points in the x-direction (mask=0 or mask=1) + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zfu(ji,jj,jk) = tmask(ji,jj-1,jk) + tmask(ji,jj,jk) + tmask(ji,jj+1,jk) - 2. + END DO + END DO + END DO + CALL lbc_lnk( 'traadv_qck', zfu(:,:,:), 'T', 1. ) !--- Lateral boundary conditions + ! + ! Tracer flux on the x-direction + DO jk = 1, jpkm1 + ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zdir = 0.5 + SIGN( 0.5, pvn(ji,jj,jk) ) ! if pun > 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) * pvn(ji,jj,jk) + END DO + END DO + END DO + ! + CALL lbc_lnk( 'traadv_qck', zwy(:,:,:), 'T', 1. ) ! Lateral boundary conditions + ! + ! Computation of the trend + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zbtr = r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + ! horizontal advective trends + ztra = - zbtr * ( zwy(ji,jj,jk) - zwy(ji,jj-1,jk) ) + !--- add it to the general tracer trends + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztra + END DO + END DO + END DO + ! ! trend diagnostics + IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:,:,:,jn) ) + ! ! "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, pwn, & + & ptn, pta, kjpt ) + !!---------------------------------------------------------------------- + !! + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + INTEGER , INTENT(in ) :: kjpt ! number of tracers + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pwn ! vertical velocity + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptn ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,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 !* Interior point (w-masked 2nd order centered flux) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zwz(ji,jj,jk) = 0.5 * pwn(ji,jj,jk) * ( ptn(ji,jj,jk-1,jn) + ptn(ji,jj,jk,jn) ) * 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 = 1, jpj + DO ji = 1, jpi + zwz(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptn(ji,jj,mikt(ji,jj),jn) ! linear free surface + END DO + END DO + ELSE ! no ocean cavities (only ocean surface) + zwz(:,:,1) = pwn(:,:,1) * ptn(:,:,1,jn) + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 !== Tracer flux divergence added to the general trend ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( zwz(ji,jj,jk) - zwz(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! ! Send trends for diagnostic + IF( l_trd ) CALL trd_tra( kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:,:,:,jn) ) + ! + 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(jpi,jpj,jpk), INTENT(in ) :: pfu ! second upwind point + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pfd ! first douwning point + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pfc ! the central point (or the first upwind point) + REAL(wp), DIMENSION(jpi,jpj,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 = 1, jpj + DO ji = 1, jpi + 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/NEMO_4.0.4_surge/src/OCE/TRA/traadv_ubs.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_ubs.F90 new file mode 100644 index 0000000..bc5ea5e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traadv_ubs.F90 @@ -0,0 +1,377 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_adv_ubs( kt, kit000, cdtype, p2dt, pun, pvn, pwn, & + & ptb, ptn, pta, kjpt, 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 pta with the now advective tracer trends + !! - send trends to trdtra module for further diagnostcs (l_trdtra=T) + !! - htr_adv, str_adv : 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 ) :: 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 + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ) :: pun, pvn, pwn ! 3 ocean transport components + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb, ptn ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + 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(jpi,jpj,jpk) :: ztu, ztv, zltu, zltv, zti, ztw ! 3D workspace + !!---------------------------------------------------------------------- + ! + 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. ln_diaptr ) 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. + ! + 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 = 1, jpjm1 ! First derivative (masked gradient) + DO ji = 1, fs_jpim1 ! vector opt. + zeeu = e2_e1u(ji,jj) * e3u_n(ji,jj,jk) * umask(ji,jj,jk) + zeev = e1_e2v(ji,jj) * e3v_n(ji,jj,jk) * vmask(ji,jj,jk) + ztu(ji,jj,jk) = zeeu * ( ptb(ji+1,jj ,jk,jn) - ptb(ji,jj,jk,jn) ) + ztv(ji,jj,jk) = zeev * ( ptb(ji ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) + END DO + END DO + DO jj = 2, jpjm1 ! Second derivative (divergence) + DO ji = fs_2, fs_jpim1 ! vector opt. + zcoef = 1._wp / ( 6._wp * e3t_n(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 + CALL lbc_lnk( 'traadv_ubs', zltu, 'T', 1. ) ; CALL lbc_lnk( 'traadv_ubs', zltv, 'T', 1. ) ! Lateral boundary cond. (unchanged sgn) + ! + DO jk = 1, jpkm1 !== Horizontal advective fluxes ==! (UBS) + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zfp_ui = pun(ji,jj,jk) + ABS( pun(ji,jj,jk) ) ! upstream transport (x2) + zfm_ui = pun(ji,jj,jk) - ABS( pun(ji,jj,jk) ) + zfp_vj = pvn(ji,jj,jk) + ABS( pvn(ji,jj,jk) ) + zfm_vj = pvn(ji,jj,jk) - ABS( pvn(ji,jj,jk) ) + ! ! 2nd order centered advective fluxes (x2) + zcenut = pun(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji+1,jj ,jk,jn) ) + zcenvt = pvn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji ,jj+1,jk,jn) ) + ! ! 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 + ! + zltu(:,:,:) = pta(:,:,:,jn) ! store the initial trends before its update + ! + DO jk = 1, jpkm1 !== add the horizontal advective trend ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) & + & - ( ztu(ji,jj,jk) - ztu(ji-1,jj ,jk) & + & + ztv(ji,jj,jk) - ztv(ji ,jj-1,jk) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + ! + END DO + ! + zltu(:,:,:) = pta(:,:,:,jn) - zltu(:,:,:) ! Horizontal advective trend used in vertical 2nd order FCT case + ! ! and/or in trend diagnostic (l_trd=T) + ! + IF( l_trd ) THEN ! trend diagnostics + CALL trd_tra( kt, cdtype, jn, jptra_xad, ztu, pun, ptn(:,:,:,jn) ) + CALL trd_tra( kt, cdtype, jn, jptra_yad, ztv, pvn, ptn(:,:,:,jn) ) + 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 ) zltv(:,:,:) = pta(:,:,:,jn) ! store pta if trend diag. + ! + ! !* upstream advection with initial mass fluxes & intermediate update ==! + DO jk = 2, jpkm1 ! Interior value (w-masked) + DO jj = 1, jpj + DO ji = 1, jpi + zfp_wk = pwn(ji,jj,jk) + ABS( pwn(ji,jj,jk) ) + zfm_wk = pwn(ji,jj,jk) - ABS( pwn(ji,jj,jk) ) + ztw(ji,jj,jk) = 0.5_wp * ( zfp_wk * ptb(ji,jj,jk,jn) + zfm_wk * ptb(ji,jj,jk-1,jn) ) * 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 = 1, jpj + DO ji = 1, jpi + ztw(ji,jj, mikt(ji,jj) ) = pwn(ji,jj,mikt(ji,jj)) * ptb(ji,jj,mikt(ji,jj),jn) ! linear free surface + END DO + END DO + ELSE ! no cavities: only at the ocean surface + ztw(:,:,1) = pwn(:,:,1) * ptb(:,:,1,jn) + ENDIF + ENDIF + ! + DO jk = 1, jpkm1 !* trend and after field with monotonic scheme + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ztak = - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ztak + zti(ji,jj,jk) = ( ptb(ji,jj,jk,jn) + p2dt * ( ztak + zltu(ji,jj,jk) ) ) * tmask(ji,jj,jk) + END DO + END DO + END DO + CALL lbc_lnk( 'traadv_ubs', zti, 'T', 1. ) ! Lateral boundary conditions on zti, zsi (unchanged sign) + ! + ! !* anti-diffusive flux : high order minus low order + DO jk = 2, jpkm1 ! Interior value (w-masked) + DO jj = 1, jpj + DO ji = 1, jpi + ztw(ji,jj,jk) = ( 0.5_wp * pwn(ji,jj,jk) * ( ptn(ji,jj,jk,jn) + ptn(ji,jj,jk-1,jn) ) & + & - 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( ptb(:,:,:,jn), ztw, zti, p2dt ) ! monotonicity algorithm + ! + CASE( 4 ) ! 4th order COMPACT + CALL interp_4th_cpt( ptn(:,:,:,jn) , ztw ) ! 4th order compact interpolation of T at w-point + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztw(ji,jj,jk) = pwn(ji,jj,jk) * ztw(ji,jj,jk) * wmask(ji,jj,jk) + END DO + END DO + END DO + IF( ln_linssh ) ztw(:,:, 1 ) = pwn(:,:,1) * ptn(:,:,1,jn) !!gm ISF & 4th COMPACT doesn't work + ! + END SELECT + ! + DO jk = 1, jpkm1 ! final trend with corrected fluxes + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) - ( ztw(ji,jj,jk) - ztw(ji,jj,jk+1) ) * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! + IF( l_trd ) THEN ! vertical advective trend diagnostics + DO jk = 1, jpkm1 ! (compute -w.dk[ptn]= -dk[w.ptn] + ptn.dk[w]) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zltv(ji,jj,jk) = pta(ji,jj,jk,jn) - zltv(ji,jj,jk) & + & + ptn(ji,jj,jk,jn) * ( pwn(ji,jj,jk) - pwn(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + CALL trd_tra( kt, cdtype, jn, jptra_zad, zltv ) + ENDIF + ! + END DO + ! + END SUBROUTINE tra_adv_ubs + + + SUBROUTINE nonosc_z( 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 + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION (jpi,jpj,jpk) :: pbef ! before field + REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,jpk) :: paft ! after field + REAL(wp), INTENT(inout), DIMENSION (jpi,jpj,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(jpi,jpj,jpk) :: zbetup, zbetdo ! 3D workspace + !!---------------------------------------------------------------------- + ! + zbig = 1.e+40_wp + zrtrn = 1.e-15_wp + zbetup(:,:,:) = 0._wp ; zbetdo(:,:,:) = 0._wp + ! + ! Search local extrema + ! -------------------- + ! ! large negative value (-zbig) inside land + pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) + paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) - zbig * ( 1.e0 - tmask(:,:,:) ) + ! + DO jk = 1, jpkm1 ! search maximum in neighbourhood + ikm1 = MAX(jk-1,1) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) + paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + zbig * ( 1.e0 - tmask(:,:,:) ) + ! + DO jk = 1, jpkm1 ! search minimum in neighbourhood + ikm1 = MAX(jk-1,1) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + pbef(:,:,:) = pbef(:,:,:) * tmask(:,:,:) + paft(:,:,:) = paft(:,:,:) * tmask(:,:,:) + ! + ! Positive and negative part of fluxes and beta terms + ! --------------------------------------------------- + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! 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_n(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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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.e0, 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/NEMO_4.0.4_surge/src/OCE/TRA/trabbc.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/trabbc.F90 new file mode 100644 index 0000000..45e368d --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/trabbc.F90 @@ -0,0 +1,196 @@ +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) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_bbc( kt ) + !!---------------------------------------------------------------------- + !! *** 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 / (rau0 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 :: ji, jj ! 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(:,:,:) = tsa(:,:,:,jp_tem) + ENDIF + ! ! Add the geothermal trend on temperature + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + tsa(ji,jj,mbkt(ji,jj),jp_tem) = tsa(ji,jj,mbkt(ji,jj),jp_tem) + qgh_trd0(ji,jj) / e3t_n(ji,jj,mbkt(ji,jj)) + END DO + END DO + ! + CALL lbc_lnk( 'trabbc', tsa(:,:,:,jp_tem) , 'T', 1. ) + ! + IF( l_trdtra ) THEN ! Send the trend for diagnostics + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) + CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbc, ztrdt ) + DEALLOCATE( ztrdt ) + ENDIF + ! + CALL iom_put ( "hfgeou" , rau0_rcp * qgh_trd0(:,:) ) + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) + READ ( numnam_ref, nambbc, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbc in reference namelist' ) + ! + REWIND( numnam_cfg ) + 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_rau0_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_rau0_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/NEMO_4.0.4_surge/src/OCE/TRA/trabbl.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/trabbl.F90 new file mode 100644 index 0000000..f6e43ed --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/trabbl.F90 @@ -0,0 +1,561 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!---------------------------------------------------------------------- + !! *** 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 + ! + 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(:,:,:) = tsa(:,:,:,jp_tem) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) + ENDIF + + IF( l_bbl ) CALL bbl( kt, nit000, 'TRA' ) !* bbl coef. and transport (only if not already done in trcbbl) + + IF( nn_bbl_ldf == 1 ) THEN !* Diffusive bbl + ! + CALL tra_bbl_dif( tsb, tsa, jpts ) + IF( ln_ctl ) & + CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_ldf - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! lateral boundary conditions ; just need for outputs + CALL lbc_lnk_multi( 'trabbl', ahu_bbl, 'U', 1. , ahv_bbl, 'V', 1. ) + 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( tsb, tsa, jpts ) + IF(ln_ctl) & + CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' bbl_adv - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! lateral boundary conditions ; just need for outputs + CALL lbc_lnk_multi( 'trabbl', utr_bbl, 'U', 1. , vtr_bbl, 'V', 1. ) + 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(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) + CALL trd_tra( kt, 'TRA', jp_tem, jptra_bbl, ztrdt ) + CALL trd_tra( kt, '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( ptb, pta, kjpt ) + !!---------------------------------------------------------------------- + !! *** 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 : pta 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jn ! dummy loop indices + INTEGER :: ik ! local integers + REAL(wp) :: zbtr ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zptb ! workspace + !!---------------------------------------------------------------------- + ! + DO jn = 1, kjpt ! tracer loop + ! ! =========== + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbkt(ji,jj) ! bottom T-level index + zptb(ji,jj) = ptb(ji,jj,ik,jn) ! bottom before T and S + END DO + END DO + ! + DO jj = 2, jpjm1 ! Compute the trend + DO ji = 2, jpim1 + ik = mbkt(ji,jj) ! bottom T-level index + pta(ji,jj,ik,jn) = pta(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_n(ji,jj,ik) + END DO + END DO + ! ! =========== + END DO ! end tracer + ! ! =========== + END SUBROUTINE tra_bbl_dif + + + SUBROUTINE tra_bbl_adv( ptb, pta, kjpt ) + !!---------------------------------------------------------------------- + !! *** 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + 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 = 1, jpjm1 + DO ji = 1, jpim1 ! 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_n(iis,jj,ikus) + ztra = zu_bbl * ( ptb(iid,jj,ikus,jn) - ptb(iis,jj,ikus,jn) ) * zbtr + pta(iis,jj,ikus,jn) = pta(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_n(iid,jj,jk) + ztra = zu_bbl * ( ptb(iid,jj,jk+1,jn) - ptb(iid,jj,jk,jn) ) * zbtr + pta(iid,jj,jk,jn) = pta(iid,jj,jk,jn) + ztra + END DO + ! + zbtr = r1_e1e2t(iid,jj) / e3t_n(iid,jj,ikud) + ztra = zu_bbl * ( ptb(iis,jj,ikus,jn) - ptb(iid,jj,ikud,jn) ) * zbtr + pta(iid,jj,ikud,jn) = pta(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_n(ji,ijs,ikvs) + ztra = zv_bbl * ( ptb(ji,ijd,ikvs,jn) - ptb(ji,ijs,ikvs,jn) ) * zbtr + pta(ji,ijs,ikvs,jn) = pta(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_n(ji,ijd,jk) + ztra = zv_bbl * ( ptb(ji,ijd,jk+1,jn) - ptb(ji,ijd,jk,jn) ) * zbtr + pta(ji,ijd,jk,jn) = pta(ji,ijd,jk,jn) + ztra + END DO + ! ! down-slope T-point (deep bottom point) + zbtr = r1_e1e2t(ji,ijd) / e3t_n(ji,ijd,ikvd) + ztra = zv_bbl * ( ptb(ji,ijs,ikvs,jn) - ptb(ji,ijd,ikvd,jn) ) * zbtr + pta(ji,ijd,ikvd,jn) = pta(ji,ijd,ikvd,jn) + ztra + ENDIF + END DO + ! + END DO + ! ! =========== + END DO ! end tracer + ! ! =========== + END SUBROUTINE tra_bbl_adv + + + SUBROUTINE bbl( kt, kit000, cdtype ) + !!---------------------------------------------------------------------- + !! *** 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 :: 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(jpi,jpj,jpts) :: zts, zab ! 3D workspace + REAL(wp), DIMENSION(jpi,jpj) :: zub, zvb, zdep ! 2D workspace + !!---------------------------------------------------------------------- + ! + 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 + ! !* bottom variables (T, S, alpha, beta, depth, velocity) + DO jj = 1, jpj + DO ji = 1, jpi + ik = mbkt(ji,jj) ! bottom T-level index + zts (ji,jj,jp_tem) = tsb(ji,jj,ik,jp_tem) ! bottom before T and S + zts (ji,jj,jp_sal) = tsb(ji,jj,ik,jp_sal) + ! + zdep(ji,jj) = gdept_n(ji,jj,ik) ! bottom T-level reference depth + zub (ji,jj) = un(ji,jj,mbku(ji,jj)) ! bottom velocity + zvb (ji,jj) = vn(ji,jj,mbkv(ji,jj)) + END DO + END DO + ! + CALL eos_rab( zts, zdep, zab ) + ! + ! !-------------------! + IF( nn_bbl_ldf == 1 ) THEN ! diffusive bbl ! + ! !-------------------! + DO jj = 1, jpjm1 ! (criteria for non zero flux: grad(rho).grad(h) < 0 ) + DO ji = 1, fs_jpim1 ! vector opt. + ! ! 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, -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, -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 = 1, jpjm1 ! criteria: grad(rho).grad(h)<0 and grad(rho).grad(h)<0 + DO ji = 1, fs_jpim1 ! vector opt. + ! ! 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, - zgdrho * REAL( mgrhu(ji,jj) ) ) ! sign of i-gradient * i-slope + zsigna= SIGN( 0.5, 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, - zgdrho * REAL( mgrhv(ji,jj) ) ) ! sign of j-gradient * j-slope + zsigna= SIGN( 0.5, 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 = 1, jpjm1 ! criteria: rho_up > rho_down + DO ji = 1, fs_jpim1 ! vector opt. + ! ! 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist nambbl in reference namelist : Bottom boundary layer scheme + READ ( numnam_ref, nambbl, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nambbl in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist nambbl in configuration namelist : Bottom boundary layer scheme + 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 = 1, jpjm1 ! (the "shelf" bottom k-indices are mbku and mbkv) + DO ji = 1, jpim1 + 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_multi( 'trabbl', zmbku,'U',1., zmbkv,'V',1.) + 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 = 1, jpjm1 + DO ji = 1, jpim1 + 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.e0, 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.e0, gdept_0(ji,jj+1,mbkt(ji,jj+1)) - gdept_0(ji,jj,mbkt(ji,jj)) ) ) + ENDIF + END DO + END DO + ! + DO jj = 1, jpjm1 !* bbl thickness at u- (v-) point + DO ji = 1, jpim1 ! 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_multi( 'trabbl', e3u_bbl_0, 'U', 1. , e3v_bbl_0, 'V', 1. ) ! 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/NEMO_4.0.4_surge/src/OCE/TRA/tradmp.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/tradmp.F90 new file mode 100644 index 0000000..83897d1 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/tradmp.F90 @@ -0,0 +1,228 @@ +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 c1d ! 1D vertical configuration + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpk,jpts) :: zts_dta + REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: ztrdts + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_dmp') + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdts(jpi,jpj,jpk,jpts) ) + ztrdts(:,:,:,:) = tsa(:,:,:,:) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + tsa(ji,jj,jk,jn) = tsa(ji,jj,jk,jn) + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jn) - tsb(ji,jj,jk,jn) ) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( avt(ji,jj,jk) <= avt_c ) THEN + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) + tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) + ENDIF + END DO + END DO + END DO + ! + CASE ( 2 ) !* no damping in the mixed layer *! + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( gdept_n(ji,jj,jk) >= hmlp (ji,jj) ) THEN + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_tem) - tsb(ji,jj,jk,jp_tem) ) + tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & + & + resto(ji,jj,jk) * ( zts_dta(ji,jj,jk,jp_sal) - tsb(ji,jj,jk,jp_sal) ) + ENDIF + END DO + END DO + END DO + ! + END SELECT + ! + IF( l_trdtra ) THEN ! trend diagnostic + ztrdts(:,:,:,:) = tsa(:,:,:,:) - ztrdts(:,:,:,:) + CALL trd_tra( kt, 'TRA', jp_tem, jptra_dmp, ztrdts(:,:,:,jp_tem) ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_dmp, ztrdts(:,:,:,jp_sal) ) + DEALLOCATE( ztrdts ) + ENDIF + ! ! Control print + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' dmp - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namtra_dmp in reference namelist : T & S relaxation + READ ( numnam_ref, namtra_dmp, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_dmp in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namtra_dmp in configuration namelist : T & S relaxation + 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_autoglo, 'resto', resto ) + CALL iom_close( imask ) + ENDIF + ! + END SUBROUTINE tra_dmp_init + + !!====================================================================== +END MODULE tradmp diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/traldf.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traldf.F90 new file mode 100644 index 0000000..b6ff66f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traldf.F90 @@ -0,0 +1,128 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf *** + !! + !! ** Purpose : compute the lateral ocean tracer physics. + !!---------------------------------------------------------------------- + INTEGER, INTENT( in ) :: kt ! ocean time-step index + !! + 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(:,:,:) = tsa(:,:,:,jp_tem) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) + 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, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsa, jpts, 1 ) + CASE ( np_lap_i ) ! laplacian: standard iso-neutral operator (Madec) + CALL tra_ldf_iso ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts, 1 ) + CASE ( np_lap_it ) ! laplacian: triad iso-neutral operator (griffies) + CALL tra_ldf_triad( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb, tsb, tsa, jpts, 1 ) + CASE ( np_blp , np_blp_i , np_blp_it ) ! bilaplacian: iso-level & iso-neutral operators + CALL tra_ldf_blp ( kt, nit000,'TRA', ahtu, ahtv, gtsu, gtsv, gtui, gtvi, tsb , tsa, jpts, nldf_tra ) + END SELECT + ! + IF( l_trdtra ) THEN !* save the horizontal diffusive trends for further diagnostics + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) + CALL trd_tra( kt, 'TRA', jp_tem, jptra_ldf, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_ldf, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! !* print mean trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' ldf - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), 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/NEMO_4.0.4_surge/src/OCE/TRA/traldf_iso.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traldf_iso.F90 new file mode 100644 index 0000000..7c9ac1b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traldf_iso.F90 @@ -0,0 +1,385 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_iso( kt, kit000, cdtype, pahu, pahv, pgu , pgv , & + & pgui, pgvi, & + & ptb , ptbb, pta , 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): + !! pta = pta + difft + !! + !! ** Action : Update pta 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 + 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptbb ! tracer (only used in kpass=2) + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ikt + INTEGER :: ierr ! 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, z2dt, z1_2dt ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zdkt, zdk1t, z2d + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw + !!---------------------------------------------------------------------- + ! + IF( kpass == 1 .AND. kt == kit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_ldf_iso : rotated laplacian diffusion operator on ', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ! + akz (:,:,:) = 0._wp + ah_wslp2(:,:,:) = 0._wp + ENDIF + ! + l_hst = .FALSE. + l_ptr = .FALSE. + IF( cdtype == 'TRA' .AND. ln_diaptr ) 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. + ! + ! ! set time step size (Euler/Leapfrog) + IF( neuler == 0 .AND. kt == nit000 ) THEN ; z2dt = rdt ! at nit000 (Euler) + ELSE ; z2dt = 2.* rdt ! (Leapfrog) + ENDIF + z1_2dt = 1._wp / z2dt + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! + 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 ) + ! + zahu_w = ( pahu(ji ,jj,jk-1) + pahu(ji-1,jj,jk) & + & + pahu(ji-1,jj,jk-1) + pahu(ji ,jj,jk) ) * zmsku + zahv_w = ( pahv(ji,jj ,jk-1) + pahv(ji,jj-1,jk) & + & + pahv(ji,jj-1,jk-1) + pahv(ji,jj ,jk) ) * 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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) ) & + & + ( 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) ) ) + END DO + END DO + END DO + ! + IF( ln_traldf_blp ) THEN ! bilaplacian operator + DO jk = 2, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk) & + & * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) ) ) + END DO + END DO + END DO + ELSEIF( ln_traldf_lap ) THEN ! laplacian operator + DO jk = 2, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) + zcoef0 = z2dt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) + akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt + END DO + END DO + END DO + ENDIF + ! + ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit + akz(:,:,:) = ah_wslp2(:,:,:) + ENDIF + ENDIF + ! + ! ! =========== + DO jn = 1, kjpt ! tracer loop + ! ! =========== + ! + !!---------------------------------------------------------------------- + !! I - masked horizontal derivative + !!---------------------------------------------------------------------- +!!gm : bug.... why (x,:,:)? (1,jpj,:) and (jpi,1,:) should be sufficient.... + zdit (1,:,:) = 0._wp ; zdit (jpi,:,:) = 0._wp + zdjt (1,:,:) = 0._wp ; zdjt (jpi,:,:) = 0._wp + !!end + + ! Horizontal tracer gradient + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zdit(ji,jj,jk) = ( ptb(ji+1,jj ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk) + zdjt(ji,jj,jk) = ( ptb(ji ,jj+1,jk,jn) - ptb(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 = 1, jpjm1 ! bottom correction (partial bottom cell) + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 + ! + ! !== Vertical tracer gradient + zdk1t(:,:) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * wmask(:,:,jk+1) ! level jk+1 + ! + IF( jk == 1 ) THEN ; zdkt(:,:) = zdk1t(:,:) ! surface: zdkt(jk=1)=zdkt(jk=2) + ELSE ; zdkt(:,:) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * wmask(:,:,jk) + ENDIF + DO jj = 1 , jpjm1 !== Horizontal fluxes + DO ji = 1, fs_jpim1 ! vector opt. + zabe1 = pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) + zabe2 = pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(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 + ! + zftu(ji,jj,jk ) = ( zabe1 * zdit(ji,jj,jk) & + & + zcof1 * ( zdkt (ji+1,jj) + zdk1t(ji,jj) & + & + zdk1t(ji+1,jj) + zdkt (ji,jj) ) ) * umask(ji,jj,jk) + zftv(ji,jj,jk) = ( zabe2 * zdjt(ji,jj,jk) & + & + zcof2 * ( zdkt (ji,jj+1) + zdk1t(ji,jj) & + & + zdk1t(ji,jj+1) + zdkt (ji,jj) ) ) * vmask(ji,jj,jk) + END DO + END DO + ! + DO jj = 2 , jpjm1 !== horizontal divergence and add to pta + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * ( zftu(ji,jj,jk) - zftu(ji-1,jj,jk) & + & + zftv(ji,jj,jk) - zftv(ji,jj-1,jk) ) & + & * r1_e1e2t(ji,jj) / e3t_n(ji,jj,jk) + END DO + END DO + END DO ! End of slab + + !!---------------------------------------------------------------------- + !! III - vertical trend (full) + !!---------------------------------------------------------------------- + ! + ztfw(fs_2:1,:,:) = 0._wp ; ztfw(jpi:fs_jpim1,:,:) = 0._wp ! avoid to potentially manipulate NaN values + ! + ! Vertical fluxes + ! --------------- + ! ! Surface and bottom vertical fluxes set to zero + ztfw(:,:, 1 ) = 0._wp ; ztfw(:,:,jpk) = 0._wp + + DO jk = 2, jpkm1 ! interior (2=<jk=<jpk-1) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! + 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 ) + ! + zahu_w = ( pahu(ji ,jj,jk-1) + pahu(ji-1,jj,jk) & + & + pahu(ji-1,jj,jk-1) + pahu(ji ,jj,jk) ) * zmsku + zahv_w = ( pahv(ji,jj ,jk-1) + pahv(ji,jj-1,jk) & + & + pahv(ji,jj-1,jk-1) + pahv(ji,jj ,jk) ) * zmskv + ! + zcoef3 = - zahu_w * e2t(ji,jj) * zmsku * wslpi (ji,jj,jk) !wslpi & j are already w-masked + zcoef4 = - zahv_w * e1t(ji,jj) * zmskv * wslpj (ji,jj,jk) + ! + ztfw(ji,jj,jk) = zcoef3 * ( zdit(ji ,jj ,jk-1) + zdit(ji-1,jj ,jk) & + & + zdit(ji-1,jj ,jk-1) + zdit(ji ,jj ,jk) ) & + & + zcoef4 * ( zdjt(ji ,jj ,jk-1) + zdjt(ji ,jj-1,jk) & + & + zdjt(ji ,jj-1,jk-1) + zdjt(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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) & + & * ( ptb(ji,jj,jk-1,jn) - ptb(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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) & + & + ah_wslp2(ji,jj,jk) * e1e2t(ji,jj) & + & * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) + END DO + END DO + END DO + CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb and ptbb gradients, resp. + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) + e1e2t(ji,jj) / e3w_n(ji,jj,jk) * wmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) ) & + & + akz (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) ) ) + END DO + END DO + END DO + END SELECT + ENDIF + ! + DO jk = 1, jpkm1 !== Divergence of vertical fluxes added to pta ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * ( ztfw (ji,jj,jk) - ztfw(ji,jj,jk+1) ) & + & * r1_e1e2t(ji,jj) / e3t_n(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) + ! note sign is reversed to give down-gradient diffusive transports ) + 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_iso + + !!============================================================================== +END MODULE traldf_iso diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/traldf_lap_blp.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traldf_lap_blp.F90 new file mode 100644 index 0000000..ed6bd6d --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traldf_lap_blp.F90 @@ -0,0 +1,234 @@ +MODULE traldf_lap_blp + !!============================================================================== + !! *** MODULE traldf_lap_blp *** + !! Ocean tracers: lateral diffusivity trend (laplacian and bilaplacian) + !!============================================================================== + !! History : 3.7 ! 2014-01 (G. Madec, S. Masson) Original code, re-entrant laplacian + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_ldf_lap : tracer trend update with iso-level laplacian diffusive operator + !! tra_ldf_blp : tracer trend update with iso-level or iso-neutral bilaplacian operator + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + USE dom_oce ! ocean space and time domain + USE ldftra ! lateral physics: eddy diffusivity + USE traldf_iso ! iso-neutral lateral diffusion (standard operator) (tra_ldf_iso routine) + USE traldf_triad ! iso-neutral lateral diffusion (triad operator) (tra_ldf_triad routine) + USE diaptr ! poleward transport diagnostics + USE diaar5 ! AR5 diagnostics + USE trc_oce ! share passive tracers/Ocean variables + 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 ! distribued memory computing library + USE timing ! Timing + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_ldf_lap ! called by traldf.F90 + PUBLIC tra_ldf_blp ! called by traldf.F90 + + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_lap( kt, kit000, cdtype, pahu, pahv, pgu , pgv , & + & pgui, pgvi, & + & ptb , pta , kjpt, kpass ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_ldf_lap *** + !! + !! ** Purpose : Compute the before horizontal tracer (t & s) diffusive + !! trend and add it to the general trend of tracer equation. + !! + !! ** Method : Second order diffusive operator evaluated using before + !! fields (forward time scheme). The horizontal diffusive trends of + !! the tracer is given by: + !! difft = 1/(e1e2t*e3t) { di-1[ pahu e2u*e3u/e1u di(tb) ] + !! + dj-1[ pahv e1v*e3v/e2v dj(tb) ] } + !! Add this trend to the general tracer trend pta : + !! pta = pta + difft + !! + !! ** Action : - Update pta arrays with the before iso-level + !! harmonic mixing trend. + !!---------------------------------------------------------------------- + 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 + 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zsign ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztu, ztv, zaheeu, zaheev + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'tra_ldf_lap : iso-level laplacian diffusion on ', cdtype, ', pass=', kpass + WRITE(numout,*) '~~~~~~~~~~~ ' + ENDIF + ! + l_hst = .FALSE. + l_ptr = .FALSE. + IF( cdtype == 'TRA' .AND. ln_diaptr ) 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. + ! + ! !== Initialization of metric arrays used for all tracers ==! + IF( kpass == 1 ) THEN ; zsign = 1._wp ! bilaplacian operator require a minus sign (eddy diffusivity >0) + ELSE ; zsign = -1._wp + ENDIF + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zaheeu(ji,jj,jk) = zsign * pahu(ji,jj,jk) * e2_e1u(ji,jj) * e3u_n(ji,jj,jk) !!gm * umask(ji,jj,jk) pah masked! + zaheev(ji,jj,jk) = zsign * pahv(ji,jj,jk) * e1_e2v(ji,jj) * e3v_n(ji,jj,jk) !!gm * vmask(ji,jj,jk) + END DO + END DO + END DO + ! + ! ! =========== ! + DO jn = 1, kjpt ! tracer loop ! + ! ! =========== ! + ! + DO jk = 1, jpkm1 !== First derivative (gradient) ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ztu(ji,jj,jk) = zaheeu(ji,jj,jk) * ( ptb(ji+1,jj ,jk,jn) - ptb(ji,jj,jk,jn) ) + ztv(ji,jj,jk) = zaheev(ji,jj,jk) * ( ptb(ji ,jj+1,jk,jn) - ptb(ji,jj,jk,jn) ) + END DO + END DO + END DO + IF( ln_zps ) THEN ! set gradient at bottom/top ocean level + DO jj = 1, jpjm1 ! bottom + DO ji = 1, fs_jpim1 + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 !== Second derivative (divergence) added to the general tracer trends ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + ( ztu(ji,jj,jk) - ztu(ji-1,jj,jk) & + & + ztv(ji,jj,jk) - ztv(ji,jj-1,jk) ) & + & / ( e1e2t(ji,jj) * e3t_n(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 + + + SUBROUTINE tra_ldf_blp( kt, kit000, cdtype, pahu, pahv, pgu , pgv , & + & pgui, pgvi, & + & ptb , pta , 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 + 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt) :: zlap ! laplacian at t-point + REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zglu, zglv ! bottom GRADh of the laplacian (u- and v-points) + REAL(wp), DIMENSION(jpi,jpj, kjpt) :: zgui, zgvi ! top GRADh of the laplacian (u- and v-points) + !!--------------------------------------------------------------------- + ! + 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 + + zlap(:,:,:,:) = 0._wp + ! + SELECT CASE ( kldf ) !== 1st laplacian applied to ptb (output in zlap) ==! + ! + CASE ( np_blp ) ! iso-level bilaplacian + CALL tra_ldf_lap ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, zlap, kjpt, 1 ) + CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) + CALL tra_ldf_iso ( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 ) + CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) + CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptb, zlap, kjpt, 1 ) + END SELECT + ! + CALL lbc_lnk( 'traldf_lap_blp', zlap(:,:,:,:) , 'T', 1. ) ! Lateral boundary conditions (unchanged sign) + ! ! Partial top/bottom cell: GRADh( zlap ) + IF( ln_isfcav .AND. ln_zps ) THEN ; CALL zps_hde_isf( kt, kjpt, zlap, zglu, zglv, zgui, zgvi ) ! both top & bottom + ELSEIF( ln_zps ) THEN ; CALL zps_hde ( kt, kjpt, zlap, zglu, zglv ) ! only bottom + ENDIF + ! + SELECT CASE ( kldf ) !== 2nd laplacian applied to zlap (output in pta) ==! + ! + CASE ( np_blp ) ! iso-level bilaplacian + CALL tra_ldf_lap ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, pta, kjpt, 2 ) + CASE ( np_blp_i ) ! rotated bilaplacian : standard operator (Madec) + CALL tra_ldf_iso ( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 ) + CASE ( np_blp_it ) ! rotated bilaplacian : triad operator (griffies) + CALL tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, zglu, zglv, zgui, zgvi, zlap, ptb, pta, kjpt, 2 ) + END SELECT + ! + END SUBROUTINE tra_ldf_blp + + !!============================================================================== +END MODULE traldf_lap_blp diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/traldf_triad.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traldf_triad.F90 new file mode 100644 index 0000000..445747d --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traldf_triad.F90 @@ -0,0 +1,432 @@ +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 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 + + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, SAVE :: zdkt3d !: vertical tracer gradient at 2 levels + + LOGICAL :: l_ptr ! flag to compute poleward transport + LOGICAL :: l_hst ! flag to compute heat transport + + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_ldf_triad( kt, kit000, cdtype, pahu, pahv, pgu , pgv , & + & pgui, pgvi, & + & ptb , ptbb, pta , 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 : pta 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 + 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! tracer (kpass=1) or laplacian of tracer (kpass=2) + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptbb ! tracer (only used in kpass=2) + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + INTEGER :: ip,jp,kp ! dummy loop indices + INTEGER :: ierr ! local integer + REAL(wp) :: zmsku, zabe1, zcof1, zcoef3 ! local scalars + REAL(wp) :: zmskv, zabe2, zcof2, zcoef4 ! - - + REAL(wp) :: zcoef0, ze3w_2, zsign, z2dt, z1_2dt ! - - + ! + REAL(wp) :: zslope_skew, zslope_iso, zslope2, zbu, zbv + REAL(wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt + REAL(wp) :: zah, zah_slp, zaei_slp + REAL(wp), DIMENSION(jpi,jpj ) :: z2d ! 2D workspace + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw ! 3D - + !!---------------------------------------------------------------------- + ! + IF( .NOT.ALLOCATED(zdkt3d) ) THEN + ALLOCATE( zdkt3d(jpi,jpj,0:1) , STAT=ierr ) + CALL mpp_sum ( 'traldf_triad', ierr ) + IF( ierr > 0 ) CALL ctl_stop('STOP', 'tra_ldf_triad: unable to allocate arrays') + ENDIF + ! + 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' .AND. ln_diaptr ) 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. + ! + ! ! set time step size (Euler/Leapfrog) + IF( neuler == 0 .AND. kt == kit000 ) THEN ; z2dt = rdt ! at nit000 (Euler) + ELSE ; z2dt = 2.* rdt ! (Leapfrog) + ENDIF + z1_2dt = 1._wp / z2dt + ! + 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 ==! + ! + akz (:,:,:) = 0._wp + ah_wslp2(:,:,:) = 0._wp + IF( ln_ldfeiv_dia ) THEN + zpsi_uw(:,:,:) = 0._wp + zpsi_vw(:,:,:) = 0._wp + ENDIF + ! + DO ip = 0, 1 ! i-k triads + DO kp = 0, 1 + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp) + zbu = e1e2u(ji,jj) * e3u_n(ji,jj,jk) + zah = 0.25_wp * pahu(ji,jj,jk) + zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) + ! Subtract s-coordinate slope at t-points to give slope rel to s-surfaces (do this by *adding* gradient of depth) + zslope2 = zslope_skew + ( gdept_n(ji+1,jj,jk) - gdept_n(ji,jj,jk) ) * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) + zslope2 = zslope2 *zslope2 + ah_wslp2(ji+ip,jj,jk+kp) = ah_wslp2(ji+ip,jj,jk+kp) + zah * zbu * ze3wr * r1_e1e2t(ji+ip,jj) * zslope2 + akz (ji+ip,jj,jk+kp) = akz (ji+ip,jj,jk+kp) + zah * r1_e1u(ji,jj) & + & * r1_e1u(ji,jj) * umask(ji,jj,jk+kp) + ! + IF( ln_ldfeiv_dia ) zpsi_uw(ji,jj,jk+kp) = zpsi_uw(ji,jj,jk+kp) & + & + 0.25_wp * aeiu(ji,jj,jk) * e2u(ji,jj) * zslope_skew + END DO + END DO + END DO + END DO + END DO + ! + DO jp = 0, 1 ! j-k triads + DO kp = 0, 1 + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze3wr = 1.0_wp / e3w_n(ji,jj+jp,jk+kp) + zbv = e1e2v(ji,jj) * e3v_n(ji,jj,jk) + zah = 0.25_wp * pahv(ji,jj,jk) + zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) + ! Subtract s-coordinate slope at t-points to give slope rel to s surfaces + ! (do this by *adding* gradient of depth) + zslope2 = zslope_skew + ( gdept_n(ji,jj+1,jk) - gdept_n(ji,jj,jk) ) * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) + zslope2 = zslope2 * zslope2 + ah_wslp2(ji,jj+jp,jk+kp) = ah_wslp2(ji,jj+jp,jk+kp) + zah * zbv * ze3wr * r1_e1e2t(ji,jj+jp) * zslope2 + akz (ji,jj+jp,jk+kp) = akz (ji,jj+jp,jk+kp) + zah * r1_e2v(ji,jj) & + & * r1_e2v(ji,jj) * vmask(ji,jj,jk+kp) + ! + IF( ln_ldfeiv_dia ) zpsi_vw(ji,jj,jk+kp) = zpsi_vw(ji,jj,jk+kp) & + & + 0.25 * aeiv(ji,jj,jk) * e1v(ji,jj) * zslope_skew + END DO + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 + akz(ji,jj,jk) = 16._wp * ah_wslp2(ji,jj,jk) & + & * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ( e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) ) ) + END DO + END DO + END DO + ELSEIF( ln_traldf_lap ) THEN ! laplacian operator + DO jk = 2, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze3w_2 = e3w_n(ji,jj,jk) * e3w_n(ji,jj,jk) + zcoef0 = z2dt * ( akz(ji,jj,jk) + ah_wslp2(ji,jj,jk) / ze3w_2 ) + akz(ji,jj,jk) = MAX( zcoef0 - 0.5_wp , 0._wp ) * ze3w_2 * z1_2dt + END DO + END DO + END DO + ENDIF + ! + ELSE ! 33 flux set to zero with akz=ah_wslp2 ==>> computed in full implicit + akz(:,:,:) = ah_wslp2(:,:,:) + ENDIF + ! + IF( ln_ldfeiv_dia .AND. cdtype == 'TRA' ) CALL ldf_eiv_dia( zpsi_uw, zpsi_vw ) + ! + 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 + ! + DO jk = 1, jpkm1 !== before lateral T & S gradients at T-level jk ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zdit(ji,jj,jk) = ( ptb(ji+1,jj ,jk,jn) - ptb(ji,jj,jk,jn) ) * umask(ji,jj,jk) + zdjt(ji,jj,jk) = ( ptb(ji ,jj+1,jk,jn) - ptb(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 = 1, jpjm1 ! bottom level + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 + zdkt3d(:,:,1) = ( ptb(:,:,jk,jn) - ptb(:,:,jk+1,jn) ) * tmask(:,:,jk+1) + ! + ! ! surface boundary condition: zdkt3d(jk=0)=zdkt3d(jk=1) + IF( jk == 1 ) THEN ; zdkt3d(:,:,0) = zdkt3d(:,:,1) + ELSE ; zdkt3d(:,:,0) = ( ptb(:,:,jk-1,jn) - ptb(:,:,jk,jn) ) * tmask(:,:,jk) + ENDIF + ! + zaei_slp = 0._wp + ! + IF( ln_botmix_triad ) THEN + DO ip = 0, 1 !== Horizontal & vertical fluxes + DO kp = 0, 1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze1ur = r1_e1u(ji,jj) + zdxt = zdit(ji,jj,jk) * ze1ur + ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp) + zdzt = zdkt3d(ji+ip,jj,kp) * ze3wr + zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) + zslope_iso = triadi (ji+ip,jj,jk,1-ip,kp) + ! + zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,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_slp = zah * zslope_iso + IF( ln_ldfeiv ) zaei_slp = aeiu(ji,jj,jk) * zslope_skew + zftu(ji ,jj,jk ) = zftu(ji ,jj,jk ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur + ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - ( zah_slp + zaei_slp) * zdxt * zbu * ze3wr + END DO + END DO + END DO + END DO + ! + DO jp = 0, 1 + DO kp = 0, 1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze2vr = r1_e2v(ji,jj) + zdyt = zdjt(ji,jj,jk) * ze2vr + ze3wr = 1._wp / e3w_n(ji,jj+jp,jk+kp) + zdzt = zdkt3d(ji,jj+jp,kp) * ze3wr + zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) + zslope_iso = triadj(ji,jj+jp,jk,1-jp,kp) + zbv = 0.25_wp * e1e2v(ji,jj) * e3v_n(ji,jj,jk) + ! ln_botmix_triad is .T. don't mask zah for bottom half cells !!gm ????? ahv is masked... + zah = pahv(ji,jj,jk) + zah_slp = zah * zslope_iso + IF( ln_ldfeiv ) zaei_slp = aeiv(ji,jj,jk) * zslope_skew + zftv(ji,jj ,jk ) = zftv(ji,jj ,jk ) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr + ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - ( zah_slp + zaei_slp ) * zdyt * zbv * ze3wr + END DO + END DO + END DO + END DO + ! + ELSE + ! + DO ip = 0, 1 !== Horizontal & vertical fluxes + DO kp = 0, 1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze1ur = r1_e1u(ji,jj) + zdxt = zdit(ji,jj,jk) * ze1ur + ze3wr = 1._wp / e3w_n(ji+ip,jj,jk+kp) + zdzt = zdkt3d(ji+ip,jj,kp) * ze3wr + zslope_skew = triadi_g(ji+ip,jj,jk,1-ip,kp) + zslope_iso = triadi(ji+ip,jj,jk,1-ip,kp) + ! + zbu = 0.25_wp * e1e2u(ji,jj) * e3u_n(ji,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_slp = zah * zslope_iso + IF( ln_ldfeiv ) zaei_slp = aeiu(ji,jj,jk) * zslope_skew ! aeit(ji+ip,jj,jk)*zslope_skew + zftu(ji ,jj,jk ) = zftu(ji ,jj,jk ) - ( zah * zdxt + (zah_slp - zaei_slp) * zdzt ) * zbu * ze1ur + ztfw(ji+ip,jj,jk+kp) = ztfw(ji+ip,jj,jk+kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr + END DO + END DO + END DO + END DO + ! + DO jp = 0, 1 + DO kp = 0, 1 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 + ze2vr = r1_e2v(ji,jj) + zdyt = zdjt(ji,jj,jk) * ze2vr + ze3wr = 1._wp / e3w_n(ji,jj+jp,jk+kp) + zdzt = zdkt3d(ji,jj+jp,kp) * ze3wr + zslope_skew = triadj_g(ji,jj+jp,jk,1-jp,kp) + zslope_iso = triadj(ji,jj+jp,jk,1-jp,kp) + zbv = 0.25_wp * e1e2v(ji,jj) * e3v_n(ji,jj,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_slp = zah * zslope_iso + IF( ln_ldfeiv ) zaei_slp = aeiv(ji,jj,jk) * zslope_skew ! aeit(ji,jj+jp,jk)*zslope_skew + zftv(ji,jj,jk) = zftv(ji,jj,jk) - ( zah * zdyt + (zah_slp - zaei_slp) * zdzt ) * zbv * ze2vr + ztfw(ji,jj+jp,jk+kp) = ztfw(ji,jj+jp,jk+kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr + END DO + END DO + END DO + END DO + ENDIF + ! !== horizontal divergence and add to the general trend ==! + DO jj = 2 , jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * ( zftu(ji-1,jj,jk) - zftu(ji,jj,jk) & + & + zftv(ji,jj-1,jk) - zftv(ji,jj,jk) ) & + & / ( e1e2t(ji,jj) * e3t_n(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 = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) - akz(ji,jj,jk) ) & + & * ( ptb(ji,jj,jk-1,jn) - ptb(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 = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk) & + & * ah_wslp2(ji,jj,jk) * ( ptb(ji,jj,jk-1,jn) - ptb(ji,jj,jk,jn) ) + END DO + END DO + END DO + CASE( 2 ) ! 2nd pass : eddy flux = ah_wslp2 and akz applied on ptb and ptbb gradients, resp. + DO jk = 2, jpkm1 + DO jj = 1, jpjm1 + DO ji = fs_2, fs_jpim1 + ztfw(ji,jj,jk) = ztfw(ji,jj,jk) - e1e2t(ji,jj) / e3w_n(ji,jj,jk) * tmask(ji,jj,jk) & + & * ( ah_wslp2(ji,jj,jk) * ( ptb (ji,jj,jk-1,jn) - ptb (ji,jj,jk,jn) ) & + & + akz (ji,jj,jk) * ( ptbb(ji,jj,jk-1,jn) - ptbb(ji,jj,jk,jn) ) ) + END DO + END DO + END DO + END SELECT + ENDIF + ! + DO jk = 1, jpkm1 !== Divergence of vertical fluxes added to pta ==! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + pta(ji,jj,jk,jn) = pta(ji,jj,jk,jn) + zsign * ( ztfw(ji,jj,jk+1) - ztfw(ji,jj,jk) ) & + & / ( e1e2t(ji,jj) * e3t_n(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 + + !!============================================================================== +END MODULE traldf_triad diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/tramle.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/tramle.F90 new file mode 100644 index 0000000..0c322a8 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/tramle.F90 @@ -0,0 +1,342 @@ +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 + + 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 /rau0 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_mle_trp( kt, kit000, pu, pv, pw, cdtype ) + !!---------------------------------------------------------------------- + !! *** 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 : - (pun,pvn,pwn) 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 + CHARACTER(len=3) , INTENT(in ) :: cdtype ! =TRA or TRC (tracer indicator) + 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(jpi,jpj) :: inml_mle + REAL(wp), DIMENSION(jpi,jpj) :: zpsim_u, zpsim_v, zmld, zbm, zhu, zhv, zn2, zLf_NH, zLf_MH + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpsi_uw, zpsi_vw + !!---------------------------------------------------------------------- + ! + ! !== MLD used for MLE ==! + ! ! compute from the 10m density to deal with the diurnal cycle + inml_mle(:,:) = mbkt(:,:) + 1 ! init. to number of ocean w-level (T-level + 1) + IF ( nla10 > 0 ) THEN ! avoid case where first level is thicker than 10m + DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 (10m) + DO jj = 1, jpj + DO ji = 1, jpi ! index of the w-level at the ML based + 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 ! MLD and mean buoyancy and N2 over the mixed layer + DO jj = 1, jpj + DO ji = 1, jpi + zc = e3t_n(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 * (rau0 - rhop(ji,jj,jk) ) * r1_rau0 + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 + zbm(:,:) = + grav * zbm(:,:) / MAX( e3t_n(:,:,1), zmld(:,:) ) + ! + ! + ! !== 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 + ! + ! !== structure function value at uw- and vw-points ==! + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zhu(ji,jj) = 1._wp / zhu(ji,jj) ! hu --> 1/hu + zhv(ji,jj) = 1._wp / zhv(ji,jj) + END DO + END DO + ! + zpsi_uw(:,:,:) = 0._wp + zpsi_vw(:,:,:) = 0._wp + ! + DO jk = 2, ikmax ! start from 2 : surface value = 0 + DO jj = 1, jpjm1 + DO ji = 1, fs_jpim1 ! vector opt. + zcuw = 1._wp - ( gdepw_n(ji+1,jj,jk) + gdepw_n(ji,jj,jk) ) * zhu(ji,jj) + zcvw = 1._wp - ( gdepw_n(ji,jj+1,jk) + gdepw_n(ji,jj,jk) ) * 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 * umask(ji,jj,jk) + zpsi_vw(ji,jj,jk) = zpsim_v(ji,jj) * zmvw * vmask(ji,jj,jk) + END DO + END DO + END DO + ! + ! !== transport increased by the MLE induced transport ==! + DO jk = 1, ikmax + DO jj = 1, jpjm1 ! CAUTION pu,pv must be defined at row/column i=1 / j=1 + DO ji = 1, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + + IF( cdtype == 'TRA') THEN !== outputs ==! + ! + zLf_NH(:,:) = SQRT( rb_c * zmld(:,:) ) * r1_ft(:,:) ! Lf = N H / f + 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 + zpsi_uw(:,:,jk) = zpsi_uw(:,:,jk) * r1_e2u(:,:) + zpsi_vw(:,:,jk) = zpsi_vw(:,:,jk) * r1_e1v(:,:) + 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 + !!---------------------------------------------------------------------- + + REWIND( numnam_ref ) ! Namelist namtra_mle in reference namelist : Tracer advection scheme + READ ( numnam_ref, namtra_mle, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_mle in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namtra_mle in configuration namelist : Tracer advection scheme + 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 /rau0 ! 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 = 2, jpj ! "coriolis+ time^-1" at u- & v-points + DO ji = fs_2, jpi ! vector opt. + 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_multi( 'tramle', rfu, 'U', 1. , rfv, 'V', 1. ) + ! + 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/NEMO_4.0.4_surge/src/OCE/TRA/tranpc.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/tranpc.F90 new file mode 100644 index 0000000..c8c2bd2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/tranpc.F90 @@ -0,0 +1,325 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_npc( kt ) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk ! dummy loop indices + INTEGER :: inpcc ! number of statically instable water column + 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_r2dt + 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(jpi,jpj,jpk ) :: zn2 ! N^2 + REAL(wp), DIMENSION(jpi,jpj,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(:,:,:) = tsa(:,:,:,jp_tem) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) + 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( tsa, zab ) ! after alpha and beta (given on T-points) + CALL bn2 ( tsa, zab, zn2 ) ! after Brunt-Vaisala (given on W-points) + ! + inpcc = 0 + ! + DO jj = 2, jpjm1 ! interior column only + DO ji = fs_2, fs_jpim1 + ! + IF( tmask(ji,jj,2) == 1 ) THEN ! At least 2 ocean points + ! ! consider one ocean column + zvts(:,jp_tem) = tsa(ji,jj,:,jp_tem) ! temperature + zvts(:,jp_sal) = tsa(ji,jj,:,jp_sal) ! 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 ) inpcc = inpcc + 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_n(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_n(ji,jj,jk ) - gdept_n(ji,jj,jk)) & + & / (gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk)) + 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_n(ji,jj,jk) * 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 tsa: + tsa(ji,jj,:,jp_tem) = zvts(:,jp_tem) + tsa(ji,jj,:,jp_sal) = 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 ! ji + END DO ! jj + ! + IF( l_trdtra ) THEN ! send the Non penetrative mixing trends for diagnostic + z1_r2dt = 1._wp / (2._wp * rdt) + ztrdt(:,:,:) = ( tsa(:,:,:,jp_tem) - ztrdt(:,:,:) ) * z1_r2dt + ztrds(:,:,:) = ( tsa(:,:,:,jp_sal) - ztrds(:,:,:) ) * z1_r2dt + CALL trd_tra( kt, 'TRA', jp_tem, jptra_npc, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_npc, ztrds ) + DEALLOCATE( ztrdt, ztrds ) + ENDIF + ! + CALL lbc_lnk_multi( 'tranpc', tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1. ) + ! + IF( lwp .AND. l_LB_debug ) THEN + WRITE(numout,*) 'Exiting tra_npc , kt = ',kt,', => numb. of statically instable water-columns: ', inpcc + WRITE(numout,*) + 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/NEMO_4.0.4_surge/src/OCE/TRA/tranxt.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/tranxt.F90 new file mode 100644 index 0000000..e80fa71 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/tranxt.F90 @@ -0,0 +1,374 @@ +MODULE tranxt + !!====================================================================== + !! *** MODULE tranxt *** + !! Ocean active tracers: time stepping on 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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! tra_nxt : time stepping on tracers + !! tra_nxt_fix : time stepping on tracers : fixed volume case + !! tra_nxt_vvl : time stepping 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 sbcisf ! 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 +#if defined key_agrif + USE agrif_oce_interp +#endif + + IMPLICIT NONE + PRIVATE + + PUBLIC tra_nxt ! routine called by step.F90 + PUBLIC tra_nxt_fix ! to be used in trcnxt + PUBLIC tra_nxt_vvl ! to be used in trcnxt + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_nxt( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tranxt *** + !! + !! ** Purpose : Apply the boundary condition on the after temperature + !! and salinity fields, achieved the time stepping by adding + !! the Asselin filter on now fields and swapping the 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 : - tsb & tsn ready for the next time step + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + !! + 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_nxt') + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_nxt : achieve the time stepping by Asselin filter and array swap' + IF(lwp) WRITE(numout,*) '~~~~~~~' + ENDIF + + ! Update after tracer on domain lateral boundaries + ! +#if defined key_agrif + CALL Agrif_tra ! AGRIF zoom boundaries +#endif + ! ! local domain boundaries (T-point, unchanged sign) + CALL lbc_lnk_multi( 'tranxt', tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1. ) + ! + IF( ln_bdy ) CALL bdy_tra( kt ) ! BDY open boundaries + + ! set time step size (Euler/Leapfrog) + IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! at nit000 (Euler) + ELSEIF( kt <= nit000 + 1 ) THEN ; r2dt = 2._wp* rdt ! at nit000 or nit000+1 (Leapfrog) + ENDIF + + ! 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, 'TRA', jp_tem, jptra_zdfp, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdfp, ztrds ) + ENDIF + ! total trend for the non-time-filtered variables. + zfact = 1.0 / rdt + ! G Nurser 23 Mar 2017. Recalculate trend as Delta(e3t*T)/e3tn; e3tn cancel from tsn terms + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( tsa(:,:,jk,jp_tem)*e3t_a(:,:,jk) / e3t_n(:,:,jk) - tsn(:,:,jk,jp_tem)) * zfact + ztrds(:,:,jk) = ( tsa(:,:,jk,jp_sal)*e3t_a(:,:,jk) / e3t_n(:,:,jk) - tsn(:,:,jk,jp_sal)) * zfact + END DO + CALL trd_tra( kt, 'TRA', jp_tem, jptra_tot, ztrdt ) + CALL trd_tra( kt, '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(:,:,:) = tsn(:,:,:,jp_tem) + ztrds(:,:,:) = tsn(:,:,:,jp_sal) + ENDIF + ENDIF + + IF( neuler == 0 .AND. kt == nit000 ) THEN ! Euler time-stepping at first time-step (only swap) + DO jn = 1, jpts + DO jk = 1, jpkm1 + tsn(:,:,jk,jn) = tsa(:,:,jk,jn) + END DO + END DO + 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_nxt_vvl that is not called on this time step + ztrdt(:,:,:) = 0._wp + ztrds(:,:,:) = 0._wp + CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + ! + ELSE ! Leap-Frog + Asselin filter time stepping + ! + IF( ln_linssh ) THEN ; CALL tra_nxt_fix( kt, nit000, 'TRA', tsb, tsn, tsa, jpts ) ! linear free surface + ELSE ; CALL tra_nxt_vvl( kt, nit000, rdt, 'TRA', tsb, tsn, tsa, & + & sbc_tsc, sbc_tsc_b, jpts ) ! non-linear free surface + ENDIF + ! + CALL lbc_lnk_multi( 'tranxt', tsb(:,:,:,jp_tem), 'T', 1., tsb(:,:,:,jp_sal), 'T', 1., & + & tsn(:,:,:,jp_tem), 'T', 1., tsn(:,:,:,jp_sal), 'T', 1., & + & tsa(:,:,:,jp_tem), 'T', 1., tsa(:,:,:,jp_sal), 'T', 1. ) + ! + ENDIF + ! + IF( l_trdtra .AND. ln_linssh ) THEN ! trend of the Asselin filter (tb filtered - tb)/dt + zfact = 1._wp / r2dt + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( tsb(:,:,jk,jp_tem) - ztrdt(:,:,jk) ) * zfact + ztrds(:,:,jk) = ( tsb(:,:,jk,jp_sal) - ztrds(:,:,jk) ) * zfact + END DO + CALL trd_tra( kt, 'TRA', jp_tem, jptra_atf, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_atf, ztrds ) + END IF + IF( l_trdtra ) DEALLOCATE( ztrdt , ztrds ) + ! + ! ! control print + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsn(:,:,:,jp_tem), clinfo1=' nxt - Tn: ', mask1=tmask, & + & tab3d_2=tsn(:,:,:,jp_sal), clinfo2= ' Sn: ', mask2=tmask ) + ! + IF( ln_timing ) CALL timing_stop('tra_nxt') + ! + END SUBROUTINE tra_nxt + + + SUBROUTINE tra_nxt_fix( kt, kit000, cdtype, ptb, ptn, pta, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_nxt_fix *** + !! + !! ** Purpose : fixed volume: apply the Asselin time filter and + !! swap the tracer fields. + !! + !! ** Method : - Apply a Asselin time filter on now fields. + !! - swap tracer fields to prepare the next time_step. + !! + !! ** Action : - tsb & tsn ready for the next time step + !!---------------------------------------------------------------------- + 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 + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptb ! before tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptn ! now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + ! + 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_nxt_fix : time stepping', cdtype + IF(lwp) WRITE(numout,*) '~~~~~~~~~~~' + ENDIF + ! + DO jn = 1, kjpt + ! + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ztn = ptn(ji,jj,jk,jn) + ztd = pta(ji,jj,jk,jn) - 2._wp * ztn + ptb(ji,jj,jk,jn) ! time laplacian on tracers + ! + ptb(ji,jj,jk,jn) = ztn + atfp * ztd ! ptb <-- filtered ptn + ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn) ! ptn <-- pta + END DO + END DO + END DO + ! + END DO + ! + END SUBROUTINE tra_nxt_fix + + + SUBROUTINE tra_nxt_vvl( kt, kit000, p2dt, cdtype, ptb, ptn, pta, psbc_tc, psbc_tc_b, kjpt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_nxt_vvl *** + !! + !! ** Purpose : Time varying volume: apply the Asselin time filter + !! and swap the tracer fields. + !! + !! ** Method : - Apply a thickness weighted Asselin time filter on now fields. + !! - swap tracer fields to prepare the next time_step. + !! tb = ( e3t_n*tn + atfp*[ e3t_b*tb - 2 e3t_n*tn + e3t_a*ta ] ) + !! /( e3t_n + atfp*[ e3t_b - 2 e3t_n + e3t_a ] ) + !! tn = ta + !! + !! ** Action : - tsb & tsn ready for the next time step + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time-step index + 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(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptb ! before tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: ptn ! now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! tracer trend + 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_nxt_vvl : time stepping', 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 = atfp * p2dt + zfact2 = zfact1 * r1_rau0 + DO jn = 1, kjpt + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ze3t_b = e3t_b(ji,jj,jk) + ze3t_n = e3t_n(ji,jj,jk) + ze3t_a = e3t_a(ji,jj,jk) + ! ! tracer content at Before, now and after + ztc_b = ptb(ji,jj,jk,jn) * ze3t_b + ztc_n = ptn(ji,jj,jk,jn) * ze3t_n + ztc_a = pta(ji,jj,jk,jn) * ze3t_a + ! + ze3t_d = ze3t_a - 2. * ze3t_n + ze3t_b + ztc_d = ztc_a - 2. * ztc_n + ztc_b + ! + ze3t_f = ze3t_n + atfp * ze3t_d + ztc_f = ztc_n + atfp * ztc_d + ! + zscale = zfact2 * e3t_n(ji,jj,jk) / ( ht_n(ji,jj) + 1._wp - ssmask(ji,jj) ) + ze3t_f = ze3t_f - zscale * ( emp_b(ji,jj) - emp(ji,jj) ) + IF ( ll_rnf ) ze3t_f = ze3t_f + zscale * ( rnf_b(ji,jj) - rnf(ji,jj) ) + IF ( ll_isf ) ze3t_f = ze3t_f - zscale * ( fwfisf_b(ji,jj) - fwfisf(ji,jj) ) + + 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) ) + ! + ! river runoff + 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_n(ji,jj,jk) / h_rnf(ji,jj) + ! + ! ice shelf + IF( ll_isf ) THEN + ! level fully include in the Losch_2008 ice shelf boundary layer + IF ( jk >= misfkt(ji,jj) .AND. jk < misfkb(ji,jj) ) & + ztc_f = ztc_f - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) ) & + & * e3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) + ! level partially include in Losch_2008 ice shelf boundary layer + IF ( jk == misfkb(ji,jj) ) & + ztc_f = ztc_f - zfact1 * ( risf_tsc(ji,jj,jn) - risf_tsc_b(ji,jj,jn) ) & + & * e3t_n(ji,jj,jk) * r1_hisf_tbl (ji,jj) * ralpha(ji,jj) + END IF + ! + ze3t_f = 1.e0 / ze3t_f + ptb(ji,jj,jk,jn) = ztc_f * ze3t_f ! ptb <-- ptn filtered + ptn(ji,jj,jk,jn) = pta(ji,jj,jk,jn) ! ptn <-- pta + ! + 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, cdtype, jp_tem, jptra_atf, ztrd_atf(:,:,:,jp_tem) ) + CALL trd_tra( kt, 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, cdtype, jn, jptra_atf, ztrd_atf(:,:,:,jn) ) + END DO + ENDIF + DEALLOCATE( ztrd_atf ) + ENDIF + ! + END SUBROUTINE tra_nxt_vvl + + !!====================================================================== +END MODULE tranxt diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/traqsr.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/traqsr.F90 new file mode 100644 index 0000000..14aad33 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/traqsr.F90 @@ -0,0 +1,444 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_qsr( kt ) + !!---------------------------------------------------------------------- + !! *** 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 ] / (rau0*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 :: 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 ! - - + REAL(wp) :: zCb, zCmax, zze, zpsi, zpsimax, zdelpsi, zCtot, zCze + REAL(wp) :: zlogc, zlogc2, zlogc3 + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zekb, zekg, zekr + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze0, ze1, ze2, ze3, zea, ztrdt + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zetot, zchl3d + !!---------------------------------------------------------------------- + ! + IF( ln_timing ) CALL timing_start('tra_qsr') + ! + 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 + ! + IF( l_trdtra ) THEN ! trends diagnostic: save the input temperature trend + ALLOCATE( ztrdt(jpi,jpj,jpk) ) + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) + ENDIF + ! + ! !-----------------------------------! + ! ! before qsr induced heat content ! + ! !-----------------------------------! + IF( kt == nit000 ) THEN !== 1st time step ==! +!!gm case neuler not taken into account.... + IF( ln_rstart .AND. iom_varid( numror, 'qsr_hc_b', ldstop = .FALSE. ) > 0 ) THEN ! read in restart + IF(lwp) WRITE(numout,*) ' nit000-1 qsr tracer content forcing field read in the restart file' + z1_2 = 0.5_wp + CALL iom_get( numror, jpdom_autoglo, 'qsr_hc_b', qsr_hc_b, ldxios = lrxios ) ! before heat content trend due to Qsr flux + ELSE ! No restart or restart not found: Euler forward time stepping + z1_2 = 1._wp + qsr_hc_b(:,:,:) = 0._wp + ENDIF + ELSE !== Swap of qsr heat content ==! + z1_2 = 0.5_wp + qsr_hc_b(:,:,:) = qsr_hc(:,:,:) + ENDIF + ! + ! !--------------------------------! + SELECT CASE( nqsr ) ! now qsr induced heat content ! + ! !--------------------------------! + ! + CASE( np_BIO ) !== bio-model fluxes ==! + ! + DO jk = 1, nksr + qsr_hc(:,:,jk) = r1_rau0_rcp * ( etot3(:,:,jk) - etot3(:,:,jk+1) ) + END DO + ! + CASE( np_RGB , np_RGBc ) !== R-G-B fluxes ==! + ! + ALLOCATE( zekb(jpi,jpj) , zekg(jpi,jpj) , zekr (jpi,jpj) , & + & ze0 (jpi,jpj,jpk) , ze1 (jpi,jpj,jpk) , ze2 (jpi,jpj,jpk) , & + & ze3 (jpi,jpj,jpk) , zea (jpi,jpj,jpk) , zchl3d(jpi,jpj,jpk) ) + ! + IF( nqsr == np_RGBc ) THEN !* Variable Chlorophyll + CALL fld_read( kt, 1, sf_chl ) ! Read Chl data and provides it at the current time step + DO jk = 1, nksr + 1 + DO jj = 2, jpjm1 ! Separation in R-G-B depending of the surface Chl + DO ji = fs_2, fs_jpim1 + zchl = MIN( 10. , MAX( 0.03, sf_chl(1)%fnow(ji,jj,1) ) ) + zCtot = 40.6 * zchl**0.459 + zze = 568.2 * zCtot**(-0.746) + IF( zze > 102. ) zze = 200.0 * zCtot**(-0.293) + zpsi = gdepw_n(ji,jj,jk) / zze + ! + zlogc = LOG( zchl ) + zlogc2 = zlogc * zlogc + zlogc3 = zlogc * zlogc * zlogc + zCb = 0.768 + 0.087 * zlogc - 0.179 * zlogc2 - 0.025 * zlogc3 + zCmax = 0.299 - 0.289 * zlogc + 0.579 * zlogc2 + zpsimax = 0.6 - 0.640 * zlogc + 0.021 * zlogc2 + 0.115 * zlogc3 + zdelpsi = 0.710 + 0.159 * zlogc + 0.021 * zlogc2 + zCze = 1.12 * (zchl)**0.803 + ! + zchl3d(ji,jj,jk) = zCze * ( zCb + zCmax * EXP( -( (zpsi - zpsimax) / zdelpsi )**2 ) ) + END DO + ! + END DO + END DO + ELSE !* constant chrlorophyll + DO jk = 1, nksr + 1 + zchl3d(:,:,jk) = 0.05 + ENDDO + ENDIF + ! + zcoef = ( 1. - rn_abs ) / 3._wp !* surface equi-partition in R-G-B + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ze0(ji,jj,1) = rn_abs * qsr(ji,jj) + ze1(ji,jj,1) = zcoef * qsr(ji,jj) + ze2(ji,jj,1) = zcoef * qsr(ji,jj) + ze3(ji,jj,1) = zcoef * qsr(ji,jj) + zea(ji,jj,1) = qsr(ji,jj) + END DO + END DO + ! + DO jk = 2, nksr+1 !* interior equi-partition in R-G-B depending of vertical profile of Chl + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zchl = MIN( 10. , MAX( 0.03, zchl3d(ji,jj,jk) ) ) + irgb = NINT( 41 + 20.*LOG10(zchl) + 1.e-15 ) + zekb(ji,jj) = rkrgb(1,irgb) + zekg(ji,jj) = rkrgb(2,irgb) + zekr(ji,jj) = rkrgb(3,irgb) + END DO + END DO + + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zc0 = ze0(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * xsi0r ) + zc1 = ze1(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekb(ji,jj) ) + zc2 = ze2(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekg(ji,jj) ) + zc3 = ze3(ji,jj,jk-1) * EXP( - e3t_n(ji,jj,jk-1) * zekr(ji,jj) ) + ze0(ji,jj,jk) = zc0 + ze1(ji,jj,jk) = zc1 + ze2(ji,jj,jk) = zc2 + ze3(ji,jj,jk) = zc3 + zea(ji,jj,jk) = ( zc0 + zc1 + zc2 + zc3 ) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + DO jk = 1, nksr !* now qsr induced heat content + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + qsr_hc(ji,jj,jk) = r1_rau0_rcp * ( zea(ji,jj,jk) - zea(ji,jj,jk+1) ) + END DO + END DO + END DO + ! + DEALLOCATE( zekb , zekg , zekr , ze0 , ze1 , ze2 , ze3 , zea , zchl3d ) + ! + CASE( np_2BD ) !== 2-bands fluxes ==! + ! + zz0 = rn_abs * r1_rau0_rcp ! surface equi-partition in 2-bands + zz1 = ( 1. - rn_abs ) * r1_rau0_rcp + DO jk = 1, nksr ! solar heat absorbed at T-point in the top 400m + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zc0 = zz0 * EXP( -gdepw_n(ji,jj,jk )*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk )*xsi1r ) + zc1 = zz0 * EXP( -gdepw_n(ji,jj,jk+1)*xsi0r ) + zz1 * EXP( -gdepw_n(ji,jj,jk+1)*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 + ! + ! !-----------------------------! + DO jk = 1, nksr ! update to the temp. trend ! + DO jj = 2, jpjm1 !-----------------------------! + DO ji = fs_2, fs_jpim1 ! vector opt. + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & + & + z1_2 * ( qsr_hc_b(ji,jj,jk) + qsr_hc(ji,jj,jk) ) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + ! + ! sea-ice: store the 1st ocean level attenuation coefficient + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF( qsr(ji,jj) /= 0._wp ) THEN ; fraqsr_1lev(ji,jj) = qsr_hc(ji,jj,1) / ( r1_rau0_rcp * qsr(ji,jj) ) + ELSE ; fraqsr_1lev(ji,jj) = 1._wp + ENDIF + END DO + END DO + CALL lbc_lnk( 'traqsr', fraqsr_1lev(:,:), 'T', 1._wp ) + ! + IF( iom_use('qsr3d') ) THEN ! output the shortwave Radiation distribution + ALLOCATE( zetot(jpi,jpj,jpk) ) + zetot(:,:,nksr+1:jpk) = 0._wp ! below ~400m set to zero + DO jk = nksr, 1, -1 + zetot(:,:,jk) = zetot(:,:,jk+1) + qsr_hc(:,:,jk) * rau0_rcp + END DO + CALL iom_put( 'qsr3d', zetot ) ! 3D distribution of shortwave Radiation + DEALLOCATE( zetot ) + ENDIF + ! + IF( lrst_oce ) THEN ! write in the ocean restart file + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'qsr_hc_b' , qsr_hc , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'fraqsr_1lev', fraqsr_1lev, ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + IF( l_trdtra ) THEN ! qsr tracers trends saved for diagnostics + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) + CALL trd_tra( kt, 'TRA', jp_tem, jptra_qsr, ztrdt ) + DEALLOCATE( ztrdt ) + ENDIF + ! ! print mean trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namtra_qsr in reference namelist + READ ( numnam_ref, namtra_qsr, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtra_qsr in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namtra_qsr in configuration 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_autoglo, 'fraqsr_1lev' , fraqsr_1lev, ldxios = lrxios ) + ELSE + fraqsr_1lev(:,:) = 1._wp ! default : no penetration + ENDIF + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('qsr_hc_b') + CALL iom_set_rstw_var_active('fraqsr_1lev') + ENDIF + ! + END SUBROUTINE tra_qsr_init + + !!====================================================================== +END MODULE traqsr diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/trasbc.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/trasbc.F90 new file mode 100644 index 0000000..17fc44a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/trasbc.F90 @@ -0,0 +1,276 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 sbcisf ! Ice shelf + USE iscplini ! Ice sheet coupling + USE traqsr ! solar radiation penetration + USE trd_oce ! trends: ocean variables + USE trdtra ! trends manager: tracers +#if defined key_asminc + USE asminc ! Assimilation increment +#endif + ! + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_sbc ( kt ) + !!---------------------------------------------------------------------- + !! *** 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, isf) contain Fext+Fwe, + !! they are simply added to the tracer trend (tsa). + !! 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 tsa 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 :: 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( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_sbc : TRAcer Surface Boundary Condition' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) + 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 + qns(:,:) = qns(:,:) + qsr(:,:) ! total heat flux in qns + qsr(:,:) = 0._wp ! qsr set to zero + ENDIF + + !---------------------------------------- + ! EMP, SFX and QNS effects + !---------------------------------------- + ! !== Set before sbc tracer content fields ==! + IF( kt == nit000 ) THEN !* 1st time-step + IF( ln_rstart .AND. & ! Restart: read in restart file + & iom_varid( numror, 'sbc_hc_b', ldstop = .FALSE. ) > 0 ) THEN + IF(lwp) WRITE(numout,*) ' nit000-1 sbc tracer content field read in the restart file' + zfact = 0.5_wp + sbc_tsc(:,:,:) = 0._wp + CALL iom_get( numror, jpdom_autoglo, 'sbc_hc_b', sbc_tsc_b(:,:,jp_tem), ldxios = lrxios ) ! before heat content sbc trend + CALL iom_get( numror, jpdom_autoglo, 'sbc_sc_b', sbc_tsc_b(:,:,jp_sal), ldxios = lrxios ) ! before salt content sbc trend + ELSE ! No restart or restart not found: Euler forward time stepping + zfact = 1._wp + sbc_tsc(:,:,:) = 0._wp + sbc_tsc_b(:,:,:) = 0._wp + ENDIF + ELSE !* other time-steps: swap of forcing fields + zfact = 0.5_wp + sbc_tsc_b(:,:,:) = sbc_tsc(:,:,:) + ENDIF + ! !== Now sbc tracer content fields ==! + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + sbc_tsc(ji,jj,jp_tem) = r1_rau0_rcp * qns(ji,jj) ! non solar heat flux + sbc_tsc(ji,jj,jp_sal) = r1_rau0 * sfx(ji,jj) ! salt flux due to freezing/melting + END DO + END DO + IF( ln_linssh ) THEN !* linear free surface + DO jj = 2, jpj !==>> add concentration/dilution effect due to constant volume cell + DO ji = fs_2, fs_jpim1 ! vector opt. + sbc_tsc(ji,jj,jp_tem) = sbc_tsc(ji,jj,jp_tem) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_tem) + sbc_tsc(ji,jj,jp_sal) = sbc_tsc(ji,jj,jp_sal) + r1_rau0 * emp(ji,jj) * tsn(ji,jj,1,jp_sal) + END DO + END DO !==>> output c./d. term + IF( iom_use('emp_x_sst') ) CALL iom_put( "emp_x_sst", emp (:,:) * tsn(:,:,1,jp_tem) ) + IF( iom_use('emp_x_sss') ) CALL iom_put( "emp_x_sss", emp (:,:) * tsn(:,:,1,jp_sal) ) + ENDIF + ! + DO jn = 1, jpts !== update tracer trend ==! + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 ! vector opt. + tsa(ji,jj,1,jn) = tsa(ji,jj,1,jn) + zfact * ( sbc_tsc_b(ji,jj,jn) + sbc_tsc(ji,jj,jn) ) / e3t_n(ji,jj,1) + END DO + END DO + END DO + ! + IF( lrst_oce ) THEN !== write sbc_tsc in the ocean restart file ==! + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'sbc_hc_b', sbc_tsc(:,:,jp_tem), ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'sbc_sc_b', sbc_tsc(:,:,jp_sal), ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ENDIF + ! + !---------------------------------------- + ! Ice Shelf effects (ISF) + ! tbl treated as in Losh (2008) JGR + !---------------------------------------- + ! +!!gm BUG ? Why no differences between non-linear and linear free surface ? +!!gm probably taken into account in r1_hisf_tbl : to be verified + IF( ln_isf ) THEN + zfact = 0.5_wp + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 + ! + ikt = misfkt(ji,jj) + ikb = misfkb(ji,jj) + ! + ! level fully include in the ice shelf boundary layer + ! sign - because fwf sign of evapo (rnf sign of precip) + DO jk = ikt, ikb - 1 + ! compute trend + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & + & + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) ) & + & * r1_hisf_tbl(ji,jj) + END DO + + ! level partially include in ice shelf boundary layer + ! compute trend + tsa(ji,jj,ikb,jp_tem) = tsa(ji,jj,ikb,jp_tem) & + & + zfact * ( risf_tsc_b(ji,jj,jp_tem) + risf_tsc(ji,jj,jp_tem) ) & + & * r1_hisf_tbl(ji,jj) * ralpha(ji,jj) + + END DO + END DO + END IF + ! + !---------------------------------------- + ! River Runoff effects + !---------------------------------------- + ! + IF( ln_rnf ) THEN ! input of heat and salt due to river runoff + zfact = 0.5_wp + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 + IF( rnf(ji,jj) /= 0._wp ) THEN + zdep = zfact / h_rnf(ji,jj) + DO jk = 1, nk_rnf(ji,jj) + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & + & + ( rnf_tsc_b(ji,jj,jp_tem) + rnf_tsc(ji,jj,jp_tem) ) * zdep + IF( ln_rnf_sal ) tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & + & + ( 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*tsn(:,:,1,jp_tem) ) ! runoff term on sst + IF( iom_use('rnf_x_sss') ) CALL iom_put( "rnf_x_sss", rnf*tsn(:,:,1,jp_sal) ) ! runoff term on sss + +#if defined key_asminc + ! + !---------------------------------------- + ! Assmilation effects + !---------------------------------------- + ! + IF( ln_sshinc ) THEN ! input of heat and salt due to assimilation + ! + IF( ln_linssh ) THEN + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 + ztim = ssh_iau(ji,jj) / e3t_n(ji,jj,1) + tsa(ji,jj,1,jp_tem) = tsa(ji,jj,1,jp_tem) + tsn(ji,jj,1,jp_tem) * ztim + tsa(ji,jj,1,jp_sal) = tsa(ji,jj,1,jp_sal) + tsn(ji,jj,1,jp_sal) * ztim + END DO + END DO + ELSE + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 + ztim = ssh_iau(ji,jj) / ( ht_n(ji,jj) + 1. - ssmask(ji, jj) ) + tsa(ji,jj,:,jp_tem) = tsa(ji,jj,:,jp_tem) + tsn(ji,jj,:,jp_tem) * ztim + tsa(ji,jj,:,jp_sal) = tsa(ji,jj,:,jp_sal) + tsn(ji,jj,:,jp_sal) * ztim + END DO + END DO + ENDIF + ! + ENDIF + ! +#endif + ! + !---------------------------------------- + ! Ice Sheet coupling imbalance correction to have conservation + !---------------------------------------- + ! + IF( ln_iscpl .AND. ln_hsb) THEN ! input of heat and salt due to river runoff + DO jk = 1,jpk + DO jj = 2, jpj + DO ji = fs_2, fs_jpim1 + zdep = 1._wp / e3t_n(ji,jj,jk) + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) - htsc_iscpl(ji,jj,jk,jp_tem) * zdep + tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) - htsc_iscpl(ji,jj,jk,jp_sal) * zdep + END DO + END DO + END DO + ENDIF + + IF( l_trdtra ) THEN ! save the horizontal diffusive trends for further diagnostics + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) + CALL trd_tra( kt, 'TRA', jp_tem, jptra_nsr, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_nsr, ztrds ) + DEALLOCATE( ztrdt , ztrds ) + ENDIF + ! + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' sbc - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ! + IF( ln_timing ) CALL timing_stop('tra_sbc') + ! + END SUBROUTINE tra_sbc + + !!====================================================================== +END MODULE trasbc diff --git a/NEMO_4.0.4_surge/src/OCE/TRA/trazdf.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/trazdf.F90 new file mode 100644 index 0000000..f616aa4 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/trazdf.F90 @@ -0,0 +1,271 @@ +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 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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE tra_zdf( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_zdf *** + !! + !! ** Purpose : compute the vertical ocean tracer physics. + !!--------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: 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(lwp)WRITE(numout,*) + IF(lwp)WRITE(numout,*) 'tra_zdf : implicit vertical mixing on T & S' + IF(lwp)WRITE(numout,*) '~~~~~~~ ' + ENDIF + ! + IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! at nit000, = rdt (restarting with Euler time stepping) + ELSEIF( kt <= nit000 + 1 ) THEN ; r2dt = 2. * rdt ! otherwise, = 2 rdt (leapfrog) + ENDIF + ! + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk) , ztrds(jpi,jpj,jpk) ) + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) + ENDIF + ! + ! !* compute lateral mixing trend and add it to the general trend + CALL tra_zdf_imp( kt, nit000, 'TRA', r2dt, tsb, tsa, 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: + WHERE( tsa(:,:,:,jp_sal) < 0._wp ) tsa(:,:,:,jp_sal) = 0.1_wp +!!gm + + IF( l_trdtra ) THEN ! save the vertical diffusive trends for further diagnostics + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( ( tsa(:,:,jk,jp_tem)*e3t_a(:,:,jk) - tsb(:,:,jk,jp_tem)*e3t_b(:,:,jk) ) & + & / (e3t_n(:,:,jk)*r2dt) ) - ztrdt(:,:,jk) + ztrds(:,:,jk) = ( ( tsa(:,:,jk,jp_sal)*e3t_a(:,:,jk) - tsb(:,:,jk,jp_sal)*e3t_b(:,:,jk) ) & + & / (e3t_n(:,:,jk)*r2dt) ) - ztrds(:,:,jk) + END DO +!!gm this should be moved in trdtra.F90 and done on all trends + CALL lbc_lnk_multi( 'trazdf', ztrdt, 'T', 1. , ztrds, 'T', 1. ) +!!gm + CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) + DEALLOCATE( ztrdt , ztrds ) + ENDIF + ! ! print mean trends (used for debugging) + IF(ln_ctl) CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' zdf - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), 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, ptb, pta, 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 : - pta becomes the after tracer + !!--------------------------------------------------------------------- + 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 + REAL(wp) , INTENT(in ) :: p2dt ! tracer time-step + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: ptb ! before and now tracer fields + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(inout) :: pta ! in: tracer trend ; out: after tracer field + ! + INTEGER :: ji, jj, jk, jn ! dummy loop indices + REAL(wp) :: zrhs, zzwi, zzws ! local scalars + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwi, zwt, zwd, zws + !!--------------------------------------------------------------------- + ! + ! ! ============= ! + 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 ; zwt(:,:,2:jpk) = avt(:,:,2:jpk) + ELSE ; zwt(:,:,2:jpk) = avs(:,:,2:jpk) + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. (ensure same order of calculation as below if wi=0.) + zzwi = - p2dt * zwt(ji,jj,jk ) / e3w_n(ji,jj,jk ) + zzws = - p2dt * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1) + zwd(ji,jj,jk) = e3t_a(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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zwi(ji,jj,jk) = - p2dt * zwt(ji,jj,jk ) / e3w_n(ji,jj,jk) + zws(ji,jj,jk) = - p2dt * zwt(ji,jj,jk+1) / e3w_n(ji,jj,jk+1) + zwd(ji,jj,jk) = e3t_a(ji,jj,jk) - zwi(ji,jj,jk) - zws(ji,jj,jk) + END DO + END DO + END DO + ENDIF + ! + !! 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 pta is used a to evaluate the rhs and then + ! used as a work space array: its value is modified. + ! + DO jj = 2, jpjm1 !* 1st recurrence: Tk = Dk - Ik Sk-1 / Tk-1 (increasing k) + DO ji = fs_2, fs_jpim1 ! 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + 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 + ! + DO jj = 2, jpjm1 !* 2nd recurrence: Zk = Yk - Ik / Tk-1 Zk-1 + DO ji = fs_2, fs_jpim1 + pta(ji,jj,1,jn) = e3t_b(ji,jj,1) * ptb(ji,jj,1,jn) + p2dt * e3t_n(ji,jj,1) * pta(ji,jj,1,jn) + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zrhs = e3t_b(ji,jj,jk) * ptb(ji,jj,jk,jn) + p2dt * e3t_n(ji,jj,jk) * pta(ji,jj,jk,jn) ! zrhs=right hand side + pta(ji,jj,jk,jn) = zrhs - zwi(ji,jj,jk) / zwt(ji,jj,jk-1) * pta(ji,jj,jk-1,jn) + END DO + END DO + END DO + ! + DO jj = 2, jpjm1 !* 3d recurrence: Xk = (Zk - Sk Xk+1 ) / Tk (result is the after tracer) + DO ji = fs_2, fs_jpim1 + pta(ji,jj,jpkm1,jn) = pta(ji,jj,jpkm1,jn) / zwt(ji,jj,jpkm1) * tmask(ji,jj,jpkm1) + END DO + END DO + DO jk = jpk-2, 1, -1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + pta(ji,jj,jk,jn) = ( pta(ji,jj,jk,jn) - zws(ji,jj,jk) * pta(ji,jj,jk+1,jn) ) & + & / 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/NEMO_4.0.4_surge/src/OCE/TRA/zpshde.F90 b/NEMO_4.0.4_surge/src/OCE/TRA/zpshde.F90 new file mode 100644 index 0000000..8966238 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRA/zpshde.F90 @@ -0,0 +1,460 @@ +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 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zps_hde( kt, kjpt, pta, pgtu, pgtv, & + & prd, pgru, pgrv ) + !!---------------------------------------------------------------------- + !! *** 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(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then + !! t~ = t(i+1,j ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) + !! ( t~ = t(i ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) ) + !! or + !! case 2-> e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then + !! t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) + !! ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) + !! 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 ) :: kjpt ! number of tracers + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(jpi,jpj ), 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(jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(jpi,jpj,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 = 1, jpjm1 + DO ji = 1, jpim1 + 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_b should be used.... + ze3wu = e3w_n(ji+1,jj ,iku) - e3w_n(ji,jj,iku) + ze3wv = e3w_n(ji ,jj+1,ikv) - e3w_n(ji,jj,ikv) + ! + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / e3w_n(ji+1,jj,iku) + ! 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_n(ji,jj,iku) + ! 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_n(ji,jj+1,ikv) + ! 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_n(ji,jj,ikv) + ! 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 + ! + CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1. ) ! 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 = 1, jpjm1 + DO ji = 1, jpim1 + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = e3w_n(ji+1,jj ,iku) - e3w_n(ji,jj,iku) + ze3wv = e3w_n(ji ,jj+1,ikv) - e3w_n(ji,jj,ikv) + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept_n(ji ,jj,iku) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = gdept_n(ji+1,jj,iku) ! - - case 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept_n(ji,jj ,ikv) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = gdept_n(ji,jj+1,ikv) ! - - 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 = 1, jpjm1 ! Gradient of density at the last level + DO ji = 1, jpim1 + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = e3w_n(ji+1,jj ,iku) - e3w_n(ji,jj,iku) + ze3wv = e3w_n(ji ,jj+1,ikv) - e3w_n(ji,jj,ikv) + 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 + CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde') + ! + END SUBROUTINE zps_hde + + + SUBROUTINE zps_hde_isf( kt, kjpt, pta, pgtu, pgtv, pgtui, pgtvi, & + & prd, pgru, pgrv, pgrui, pgrvi ) + !!---------------------------------------------------------------------- + !! *** 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(i+1) >= e3w(i) ( and e3w(j+1) >= e3w(j) ) then + !! t~ = t(i+1,j ,k) + (e3w(i+1) - e3w(i)) * dk(Ti+1)/e3w(i+1) + !! ( t~ = t(i ,j+1,k) + (e3w(j+1) - e3w(j)) * dk(Tj+1)/e3w(j+1) ) + !! or + !! case 2-> e3w(i+1) <= e3w(i) ( and e3w(j+1) <= e3w(j) ) then + !! t~ = t(i,j,k) + (e3w(i) - e3w(i+1)) * dk(Ti)/e3w(i ) + !! ( t~ = t(i,j,k) + (e3w(j) - e3w(j+1)) * dk(Tj)/e3w(j ) ) + !! 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 ) :: kjpt ! number of tracers + REAL(wp), DIMENSION(jpi,jpj,jpk,kjpt), INTENT(in ) :: pta ! 4D tracers fields + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtu, pgtv ! hor. grad. of ptra at u- & v-pts + REAL(wp), DIMENSION(jpi,jpj, kjpt), INTENT( out) :: pgtui, pgtvi ! hor. grad. of stra at u- & v-pts (ISF) + REAL(wp), DIMENSION(jpi,jpj,jpk ), INTENT(in ), OPTIONAL :: prd ! 3D density anomaly fields + REAL(wp), DIMENSION(jpi,jpj ), INTENT( out), OPTIONAL :: pgru, pgrv ! hor. grad of prd at u- & v-pts (bottom) + REAL(wp), DIMENSION(jpi,jpj ), 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(jpi,jpj) :: zri, zrj, zhi, zhj ! NB: 3rd dim=1 to use eos + REAL(wp), DIMENSION(jpi,jpj,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 = 1, jpjm1 + DO ji = 1, jpim1 + + 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_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) + ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) + ! + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / e3w_n(ji+1,jj,iku) + ! 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_n(ji,jj,iku) + ! 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_n(ji,jj+1,ikv) + ! 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_n(ji,jj,ikv) + ! 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 + ! + CALL lbc_lnk_multi( 'zpshde', pgtu(:,:,:), 'U', -1. , pgtv(:,:,:), 'V', -1. ) ! 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 = 1, jpjm1 + DO ji = 1, jpim1 + + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) + ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) + ! + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept_n(ji ,jj,iku) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = gdept_n(ji+1,jj,iku) ! - - case 2 + ENDIF + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept_n(ji,jj ,ikv) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = gdept_n(ji,jj+1,ikv) ! - - 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 = 1, jpjm1 ! Gradient of density at the last level + DO ji = 1, jpim1 + iku = mbku(ji,jj) + ikv = mbkv(ji,jj) + ze3wu = gdept_n(ji+1,jj,iku) - gdept_n(ji,jj,iku) + ze3wv = gdept_n(ji,jj+1,ikv) - gdept_n(ji,jj,ikv) + + 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 + + CALL lbc_lnk_multi( 'zpshde', pgru , 'U', -1. , pgrv , 'V', -1. ) ! Lateral boundary conditions + ! + END IF + ! + ! !== (ISH) compute grui and gruvi ==! + ! + DO jn = 1, kjpt !== Interpolation of tracers at the last ocean level ==! ! + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + 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(i,j) - e3w(i,j+1) 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_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) + ze3wv = gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv) + + ! i- direction + IF( ze3wu >= 0._wp ) THEN ! case 1 + zmaxu = ze3wu / e3w_n(ji+1,jj,ikup1) + ! 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_n(ji,jj,ikup1) + ! 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_n(ji,jj+1,ikvp1) + ! 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_n(ji,jj,ikvp1) + ! 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 + CALL lbc_lnk_multi( 'zpshde', pgtui(:,:,:), 'U', -1. , pgtvi(:,:,:), 'V', -1. ) ! 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 = 1, jpjm1 + DO ji = 1, jpim1 + + iku = miku(ji,jj) + ikv = mikv(ji,jj) + ze3wu = gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) + ze3wv = gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv) + ! + IF( ze3wu >= 0._wp ) THEN ; zhi(ji,jj) = gdept_n(ji ,jj,iku) ! i-direction: case 1 + ELSE ; zhi(ji,jj) = gdept_n(ji+1,jj,iku) ! - - case 2 + ENDIF + + IF( ze3wv >= 0._wp ) THEN ; zhj(ji,jj) = gdept_n(ji,jj ,ikv) ! j-direction: case 1 + ELSE ; zhj(ji,jj) = gdept_n(ji,jj+1,ikv) ! - - 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 = 1, jpjm1 ! Gradient of density at the last level + DO ji = 1, jpim1 + iku = miku(ji,jj) + ikv = mikv(ji,jj) + ze3wu = gdept_n(ji,jj,iku) - gdept_n(ji+1,jj,iku) + ze3wv = gdept_n(ji,jj,ikv) - gdept_n(ji,jj+1,ikv) + + 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 + CALL lbc_lnk_multi( 'zpshde', pgrui, 'U', -1. , pgrvi, 'V', -1. ) ! Lateral boundary conditions + ! + END IF + ! + IF( ln_timing ) CALL timing_stop( 'zps_hde_isf') + ! + END SUBROUTINE zps_hde_isf + + !!====================================================================== +END MODULE zpshde diff --git a/NEMO_4.0.4_surge/src/OCE/TRD/trd_oce.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trd_oce.F90 new file mode 100644 index 0000000..019eeb6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trd_oce.F90 @@ -0,0 +1,82 @@ +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) + +# if ( defined key_trdtrc && defined key_iomput ) || defined key_trdmxl_trc + LOGICAL , PUBLIC :: l_trdtrc = .TRUE. !: tracers trend flag +# else + LOGICAL , PUBLIC :: l_trdtrc = .FALSE. !: tracers trend flag +# endif + ! !!!* Active tracers trends indexes + INTEGER, PUBLIC, PARAMETER :: jptot_tra = 20 !: 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_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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trd_oce diff --git a/NEMO_4.0.4_surge/src/OCE/TRD/trddyn.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trddyn.F90 new file mode 100644 index 0000000..a5ff469 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trddyn.F90 @@ -0,0 +1,183 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_dyn( putrd, pvtrd, ktrd, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_mod *** + !! + !! ** Purpose : Dispatch momentum trend computation, e.g. 3D output, + !! integral constraints, barotropic vorticity, kinetic enrgy, + !! and/or mixed layer budget. + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + !!---------------------------------------------------------------------- + ! + 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 ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Integral Constraints Properties for momentum and/or tracers trends + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_glo_trd ) CALL trd_glo( putrd, pvtrd, ktrd, 'DYN', kt ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Kinetic Energy trends + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_KE_trd ) CALL trd_ken( putrd, pvtrd, ktrd, kt ) + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! Vorticity trends + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF( ln_vor_trd ) CALL trd_vor( putrd, pvtrd, ktrd, kt ) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! 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 ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_dyn_iom *** + !! + !! ** Purpose : output 3D trends using IOM + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + ! + 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 ! no mask as un,vn are masked + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + z3dx(ji,jj,jk) = un(ji,jj,jk) * ( un(ji+1,jj,jk) - un(ji-1,jj,jk) ) / ( 2._wp * e1u(ji,jj) ) + z3dy(ji,jj,jk) = vn(ji,jj,jk) * ( vn(ji,jj+1,jk) - vn(ji,jj-1,jk) ) / ( 2._wp * e2v(ji,jj) ) + END DO + END DO + END DO + CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1., z3dy, 'V', -1. ) + 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_n(:,:,1) * rau0 ) + z2dy(:,:) = ( vtau_b(:,:) + vtau(:,:) ) / ( e3v_n(:,:,1) * rau0 ) + 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) ) & +! & * un(ji,jj,ikbu) / e3u_n(ji,jj,ikbu) +! z3dy(ji,jj,jk) = 0.5 * ( rCdU_bot(ji,jj+1) + rCdU_bot(ji,jj) ) & +! & * vn(ji,jj,ikbv) / e3v_n(ji,jj,ikbv) +! END DO +! END DO +! END DO +! CALL lbc_lnk_multi( 'trddyn', z3dx, 'U', -1., z3dy, 'V', -1. ) +! 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/NEMO_4.0.4_surge/src/OCE/TRD/trdglo.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdglo.F90 new file mode 100644 index 0000000..eca010f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdglo.F90 @@ -0,0 +1,559 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_glo( ptrdx, ptrdy, ktrd, ctype, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_glo *** + !! + !! ** Purpose : compute and print global domain averaged trends for + !! T, T^2, momentum, KE, and KE<->PE + !! + !!---------------------------------------------------------------------- + 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 + CHARACTER(len=3) , INTENT(in ) :: ctype ! momentum or tracers trends type (='DYN'/'TRA') + INTEGER , INTENT(in ) :: kt ! time step + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbu, ikbv ! local integers + REAL(wp):: zvm, zvt, zvs, z1_2rau0 ! 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 ! global sum of mask volume trend and trend*T (including interior mask) + DO jj = 1, jpj + DO ji = 1, jpi + zvm = e1e2t(ji,jj) * e3t_n(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 * tsn(ji,jj,jk,jp_tem) + s2 (ktrd) = s2(ktrd) + zvs * tsn(ji,jj,jk,jp_sal) + 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( wn(:,:,1) * tsn(:,:,1,jp_tem) * e1e2t(:,:) * tmask_i(:,:) ) + smo(jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_sal) * e1e2t(:,:) * tmask_i(:,:) ) + t2 (jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_tem) * tsn(:,:,1,jp_tem) * e1e2t(:,:) * tmask_i(:,:) ) + s2 (jptra_sad) = SUM( wn(:,:,1) * tsn(:,:,1,jp_sal) * tsn(:,:,1,jp_sal) * 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 = 1, jpjm1 + DO ji = 1, jpim1 + zvt = ptrdx(ji,jj,jk) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & + & * e1e2u (ji,jj) * e3u_n(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_n(ji,jj,jk) + umo(ktrd) = umo(ktrd) + zvt + vmo(ktrd) = vmo(ktrd) + zvs + hke(ktrd) = hke(ktrd) + un(ji,jj,jk) * zvt + vn(ji,jj,jk) * zvs + END DO + END DO + END DO + ! + IF( ktrd == jpdyn_zdf ) THEN ! zdf trend: compute separately the surface forcing trend + z1_2rau0 = 0.5_wp / rau0 + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zvt = ( utau_b(ji,jj) + utau(ji,jj) ) * tmask_i(ji+1,jj) * tmask_i(ji,jj) * umask(ji,jj,jk) & + & * z1_2rau0 * 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_2rau0 * e1e2v(ji,jj) + umo(jpdyn_tau) = umo(jpdyn_tau) + zvt + vmo(jpdyn_tau) = vmo(jpdyn_tau) + zvs + hke(jpdyn_tau) = hke(jpdyn_tau) + un(ji,jj,1) * zvt + vn(ji,jj,1) * 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_2rau0 = 0.5_wp / rau0 +! 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) ) * un(ji,jj,ikbu) * e1e2u(ji,jj) +! zvs = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) * vn(ji,jj,ikbv) * e1e2v(ji,jj) +! umo(jpdyn_bfri) = umo(jpdyn_bfri) + zvt +! vmo(jpdyn_bfri) = vmo(jpdyn_bfri) + zvs +! hke(jpdyn_bfri) = hke(jpdyn_bfri) + un(ji,jj,ikbu) * zvt + vn(ji,jj,ikbv) * 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 ) + !!--------------------------------------------------------------------- + !! *** 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 :: 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( tsn, rhd, rhop ) ! now potential density + + zcof = 0.5_wp / rau0 ! Density flux at w-point + zkz(:,:,1) = 0._wp + DO jk = 2, jpk + zkz(:,:,jk) = zcof * e1e2t(:,:) * wn(:,:,jk) * ( rhop(:,:,jk) + rhop(:,:,jk-1) ) * tmask_i(:,:) + END DO + + zcof = 0.5_wp / rau0 ! Density flux at u and v-points + DO jk = 1, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, jpim1 + zkx(ji,jj,jk) = zcof * e2u(ji,jj) * e3u_n(ji,jj,jk) * un(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji+1,jj,jk) ) + zky(ji,jj,jk) = zcof * e1v(ji,jj) * e3v_n(ji,jj,jk) * vn(ji,jj,jk) * ( rhop(ji,jj,jk) + rhop(ji,jj+1,jk) ) + END DO + END DO + END DO + + DO jk = 1, jpkm1 ! Density flux divergence at t-point + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + 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_n(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_n(:,:,jk) * e1e2t(:,:) * e3t_n(:,:,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/rau0 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 + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_glo_init *** + !! + !! ** Purpose : Read the namtrd namelist + !!---------------------------------------------------------------------- + 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_n(:,:,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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + tvolu = tvolu + e1u(ji,jj) * e2u(ji,jj) * e3u_n(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_n(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/NEMO_4.0.4_surge/src/OCE/TRD/trdini.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdini.F90 new file mode 100644 index 0000000..6865daf --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdini.F90 @@ -0,0 +1,107 @@ +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 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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_init + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_init *** + !! + !! ** Purpose : Initialization of trend diagnostics + !!---------------------------------------------------------------------- + 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namtrd in reference namelist : trends diagnostic + READ ( numnam_ref, namtrd, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namtrd in configuration namelist : trends diagnostic + 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' ) + +!!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 ! 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/NEMO_4.0.4_surge/src/OCE/TRD/trdken.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdken.F90 new file mode 100644 index 0000000..2b3e630 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdken.F90 @@ -0,0 +1,256 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!--------------------------------------------------------------------- + !! *** 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[ un * putrd * bu ] + mj-1[ vn * 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(wp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V masked trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + ! + 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_multi( 'trdken', putrd, 'U', -1. , pvtrd, 'V', -1. ) ! lateral boundary conditions + ! + nkstp = kt + DO jk = 1, jpkm1 + bu (:,:,jk) = e1e2u(:,:) * e3u_n(:,:,jk) + bv (:,:,jk) = e1e2v(:,:) * e3v_n(:,:,jk) + r1_bt(:,:,jk) = r1_e1e2t(:,:) / e3t_n(:,:,jk) * tmask(:,:,jk) + END DO + ! + zke(:,:,jpk) = 0._wp + zke(1,:, : ) = 0._wp + zke(:,1, : ) = 0._wp + DO jk = 1, jpkm1 + DO jj = 2, jpj + DO ji = 2, jpi + zke(ji,jj,jk) = 0.5_wp * rau0 *( un(ji ,jj,jk) * putrd(ji ,jj,jk) * bu(ji ,jj,jk) & + & + un(ji-1,jj,jk) * putrd(ji-1,jj,jk) * bu(ji-1,jj,jk) & + & + vn(ji,jj ,jk) * pvtrd(ji,jj ,jk) * bv(ji,jj ,jk) & + & + vn(ji,jj-1,jk) * 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(:,:) = un(:,:,1) * ( utau_b(:,:) + utau(:,:) ) * e1e2u(:,:) * umask(:,:,1) + z2dy(:,:) = vn(:,:,1) * ( vtau_b(:,:) + vtau(:,:) ) * e1e2v(:,:) * vmask(:,:,1) + zke2d(1,:) = 0._wp ; zke2d(:,1) = 0._wp + DO jj = 2, jpj + DO ji = 2, jpi + zke2d(ji,jj) = r1_rau0 * 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) = un(ji,jj,ikbu) * bfrua(ji,jj) * un(ji,jj,ikbu) +! z2dy(ji,jj) = vn(ji,jj,ikbu) * bfrva(ji,jj) * vn(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) ) * 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" un,vn 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) = un(ji,jj,ikbu) * bfrua(ji,jj) * un(ji,jj,ikbu) / e3u_n(ji,jj,ikbu) +! z2dy(ji,jj) = un(ji,jj,ikbu) * bfrva(ji,jj) * vn(ji,jj,ikbv) / e3v_n(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=ua and pvtrd=va + zke(:,:,:) = 0.5_wp * zke(:,:,:) + CALL iom_put( "KE", zke ) + ! + CALL ken_p2k( kt , zke ) + CALL iom_put( "ketrd_convP2K", zke ) ! conversion -rau*g*w + ! + END SELECT + ! + END SUBROUTINE trd_ken + + + SUBROUTINE ken_p2k( kt , pconv ) + !!--------------------------------------------------------------------- + !! *** 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 + 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 = - rau0 * grav * 0.5_wp + + ! Surface value (also valid in partial step case) + zconv(:,:,1) = zcoef * ( 2._wp * rhd(:,:,1) ) * wn(:,:,1) * e3w_n(:,:,1) + + ! interior value (2=<jk=<jpkm1) + DO jk = 2, jpk + zconv(:,:,jk) = zcoef * ( rhd(:,:,jk) + rhd(:,:,jk-1) ) * wn(:,:,jk) * e3w_n(:,:,jk) + END DO + + ! conv value on T-point + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zcoef = 0.5_wp / e3t_n(ji,jj,jk) + pconv(ji,jj,jk) = zcoef * ( zconv(ji,jj,jk) + zconv(ji,jj,jk+1) ) * tmask(ji,jj,jk) + END DO + END DO + END DO + ! + END SUBROUTINE ken_p2k + + + SUBROUTINE trd_ken_init + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_ken_init *** + !! + !! ** Purpose : initialisation of 3D Kinetic Energy trend diagnostic + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + ! + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'trd_ken_init : 3D Kinetic Energy trends' + WRITE(numout,*) '~~~~~~~~~~~~~' + ENDIF + ! ! allocate box volume arrays + IF( trd_ken_alloc() /= 0 ) CALL ctl_stop('trd_ken_alloc: failed to allocate arrays') + ! + END SUBROUTINE trd_ken_init + + !!====================================================================== +END MODULE trdken diff --git a/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl.F90 new file mode 100644 index 0000000..8909677 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl.F90 @@ -0,0 +1,869 @@ +MODULE trdmxl + !!====================================================================== + !! *** MODULE trdmxl *** + !! Ocean diagnostics: mixed layer T-S trends + !!====================================================================== + !! History : OPA ! 1995-04 (J. Vialard) Original code + !! ! 1997-02 (E. Guilyardi) Adaptation global + base cmo + !! ! 1999-09 (E. Guilyardi) Re-writing + netCDF output + !! NEMO 1.0 ! 2002-06 (G. Madec) F90: Free form and module + !! - ! 2004-08 (C. Talandier) New trends organization + !! 2.0 ! 2005-05 (C. Deltel) Diagnose trends of time averaged ML T & S + !! 3.5 ! 2012-03 (G. Madec) complete reorganisation + change in the time averaging + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! trd_mxl : T and S cumulated trends averaged over the mixed layer + !! trd_mxl_zint : T and S trends vertical integration + !! trd_mxl_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 trdmxl_oce ! ocean variables trends + USE ldftra ! lateral diffusion: eddy diffusivity & EIV coeff. + USE zdf_oce ! ocean vertical physics + USE phycst ! Define parameters for the routines + USE dianam ! build the name of file (routine) + USE ldfslp ! iso-neutral slopes + USE zdfmxl ! mixed layer depth + USE zdfddm ! ocean vertical physics: double diffusion + USE lbclnk ! ocean lateral boundary conditions (or mpp link) + USE trdmxl_rst ! restart for diagnosing the ML trends + ! + USE in_out_manager ! I/O manager + USE ioipsl ! NetCDF library + USE prtctl ! Print control + USE restart ! for lrst_oce + USE lib_mpp ! MPP library + USE iom + + IMPLICIT NONE + PRIVATE + + PUBLIC trd_mxl ! routine called by step.F90 + PUBLIC trd_mxl_init ! routine called by opa.F90 + PUBLIC trd_mxl_zint ! routine called by tracers routines + + INTEGER :: nkstp ! current time step + +!!gm to be moved from trdmxl_oce +! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: hml ! ML depth (sum of e3t over nmln-1 levels) [m] +! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tml , sml ! now ML averaged T & S +! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tmlb_nf, smlb_nf ! not filtered before ML averaged T & S +! +! +! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: hmlb, hmln ! before, now, and after Mixed Layer depths [m] +! +! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tb_mlb, tb_mln ! before (not filtered) tracer averaged over before and now ML +! +! REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: tn_mln ! now tracer averaged over now ML +!!gm end + + CHARACTER (LEN=40) :: clhstnam ! name of the trends NetCDF file + INTEGER :: nh_t, nmoymltrd + INTEGER :: nidtrd + INTEGER, ALLOCATABLE, SAVE, DIMENSION(:) :: ndextrd1 + INTEGER :: ndimtrd1 + INTEGER :: ionce, icount + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION trd_mxl_alloc() + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_mxl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( ndextrd1(jpi*jpj) , STAT=trd_mxl_alloc ) + ! + CALL mpp_sum ( 'trdmxl', trd_mxl_alloc ) + IF( trd_mxl_alloc /= 0 ) CALL ctl_warn('trd_mxl_alloc: failed to allocate array ndextrd1') + END FUNCTION trd_mxl_alloc + + + SUBROUTINE trd_tra_mxl( ptrdx, ptrdy, ktrd, kt, p2dt, kmxln ) + !!---------------------------------------------------------------------- + !! *** 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(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 + REAL(wp) , INTENT(in ) :: p2dt ! time step [s] + REAL(wp), DIMENSION(:,:) , INTENT(in ) :: kmxln ! number of t-box for the vertical average + ! + INTEGER :: ji, jj, jk ! dummy loop indices + !!---------------------------------------------------------------------- + + ! !==============================! + IF ( kt /= nkstp ) THEN != 1st call at kt time step =! + ! !==============================! + nkstp = kt + + + ! !== reset trend arrays to zero ==! + tmltrd(:,:,:) = 0._wp ; smltrd(:,:,:) = 0._wp + + + ! + wkx(:,:,:) = 0._wp !== now ML weights for vertical averaging ==! + DO jk = 1, jpktrd ! initialize wkx with vertical scale factor in mixed-layer + DO jj = 1,jpj + DO ji = 1,jpi + IF( jk - kmxln(ji,jj) < 0 ) wkx(ji,jj,jk) = e3t_n(ji,jj,jk) * tmask(ji,jj,jk) + END DO + END DO + END DO + hmxl(:,:) = 0._wp ! NOW mixed-layer depth + DO jk = 1, jpktrd + hmxl(:,:) = hmxl(:,:) + wkx(:,:,jk) + END DO + DO jk = 1, jpktrd ! integration weights + wkx(:,:,jk) = wkx(:,:,jk) / MAX( 1.e-20_wp, hmxl(:,:) ) * tmask(:,:,1) + END DO + + + ! + ! !== Vertically averaged T and S ==! + tml(:,:) = 0._wp ; sml(:,:) = 0._wp + DO jk = 1, jpktrd + tml(:,:) = tml(:,:) + wkx(:,:,jk) * tsn(:,:,jk,jp_tem) + sml(:,:) = sml(:,:) + wkx(:,:,jk) * tsn(:,:,jk,jp_sal) + END DO + ! + ENDIF + + + + ! mean now trends over the now ML + tmltrd(:,:,ktrd) = tmltrd(:,:,ktrd) + ptrdx(:,:,jk) * wkx(:,:,jk) ! temperature + smltrd(:,:,ktrd) = smltrd(:,:,ktrd) + ptrdy(:,:,jk) * wkx(:,:,jk) ! salinity + + + +!!gm to be put juste before the output ! +! ! Lateral boundary conditions +! CALL lbc_lnk_multi( 'trdmxl', tmltrd(:,:,jl), 'T', 1. , smltrd(:,:,jl), 'T', 1. ) +!!gm end + + + + SELECT CASE( ktrd ) + CASE( jptra_npc ) ! non-penetrative convection: regrouped with zdf +!!gm : to be completed ! +! IF( .... +!!gm end + CASE( jptra_zdfp ) ! iso-neutral diffusion: "pure" vertical diffusion +! ! regroup iso-neutral diffusion in one term + tmltrd(:,:,jpmxl_ldf) = tmltrd(:,:,jpmxl_ldf) + ( tmltrd(:,:,jpmxl_zdf) - tmltrd(:,:,jpmxl_zdfp) ) + smltrd(:,:,jpmxl_ldf) = smltrd(:,:,jpmxl_ldf) + ( smltrd(:,:,jpmxl_zdf) - smltrd(:,:,jpmxl_zdfp) ) + ! ! put in zdf the dia-neutral diffusion + tmltrd(:,:,jpmxl_zdf) = tmltrd(:,:,jpmxl_zdfp) + smltrd(:,:,jpmxl_zdf) = smltrd(:,:,jpmxl_zdfp) + IF( ln_zdfnpc ) THEN + tmltrd(:,:,jpmxl_zdf) = tmltrd(:,:,jpmxl_zdf) + tmltrd(:,:,jpmxl_npc) + smltrd(:,:,jpmxl_zdf) = smltrd(:,:,jpmxl_zdf) + smltrd(:,:,jpmxl_npc) + ENDIF + ! + CASE( jptra_atf ) ! last trends of the current time step: perform the time averaging & output + ! + ! after ML : zhmla NB will be swaped to provide hmln and hmlb + ! + ! entrainement ent_1 : tb_mln - tb_mlb ==>> 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(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pttrdmxl ! temperature trend + REAL(wp), 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( ln_ctl ) 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. ( ln_ctl ) ) 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_multi( 'trdmxl', ztmltot , 'T', 1., zsmltot , 'T', 1., & + & ztmlres , 'T', 1., zsmlres , 'T', 1., & + & ztmlatf , 'T', 1., zsmlatf , 'T', 1. ) + + + ! 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_multi( 'trdmxl', ztmltot2, 'T', 1., zsmltot2, 'T', 1., & + & ztmlres2, 'T', 1., zsmlres2, 'T', 1. ) + ! + CALL lbc_lnk_multi( 'trdmxl', ztmltrd2(:,:,:), 'T', 1., zsmltrd2(:,:,:), 'T', 1. ) ! / 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( ln_ctl ) 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(wp) :: 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namtrd_mxl in reference namelist : mixed layer trends diagnostic + READ ( numnam_ref, namtrd_mxl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namtrd_mxl in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namtrd_mxl in configuration namelist : mixed layer trends diagnostic + 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/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl_oce.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl_oce.F90 new file mode 100644 index 0000000..1391012 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl_oce.F90 @@ -0,0 +1,135 @@ +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$ + !! 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/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl_rst.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl_rst.F90 new file mode 100644 index 0000000..2a80100 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdmxl_rst.F90 @@ -0,0 +1,190 @@ +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$ + !! 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_autoglo, 'tmlbb' , tmlbb ) + CALL iom_get( inum, jpdom_autoglo, 'tmlbn' , tmlbn ) + CALL iom_get( inum, jpdom_autoglo, 'tmlatfb' , tmlatfb ) + ! + !-- Salinity + CALL iom_get( inum, jpdom_autoglo, 'smlbb' , smlbb ) + CALL iom_get( inum, jpdom_autoglo, 'smlbn' , smlbn ) + CALL iom_get( inum, jpdom_autoglo, 'smlatfb' , smlatfb ) + ELSE + CALL iom_get( inum, jpdom_autoglo, 'hmxlbn' , hmxlbn ) ! needed for hmxl_sum + ! + !-- Temperature + CALL iom_get( inum, jpdom_autoglo, 'tmlbn' , tmlbn ) ! needed for tml_sum + CALL iom_get( inum, jpdom_autoglo, '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_autoglo, charout, tmltrd_csum_ub(:,:,jk) ) + END DO + CALL iom_get( inum, jpdom_autoglo, 'tmltrd_atf_sumb' , tmltrd_atf_sumb) + ! + !-- Salinity + CALL iom_get( inum, jpdom_autoglo, 'smlbn' , smlbn ) ! needed for sml_sum + CALL iom_get( inum, jpdom_autoglo, '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_autoglo, charout, smltrd_csum_ub(:,:,jk) ) + END DO + CALL iom_get( inum, jpdom_autoglo, 'smltrd_atf_sumb' , smltrd_atf_sumb) + ! + CALL iom_close( inum ) + ENDIF + ! + END SUBROUTINE trd_mxl_rst_read + + !!================================================================================= +END MODULE trdmxl_rst diff --git a/NEMO_4.0.4_surge/src/OCE/TRD/trdpen.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdpen.F90 new file mode 100644 index 0000000..6214d93 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdpen.F90 @@ -0,0 +1,155 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!--------------------------------------------------------------------- + !! *** 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(wp), DIMENSION(:,:,:), INTENT(in) :: ptrdx, ptrdy ! Temperature & Salinity trends + INTEGER , INTENT(in) :: ktrd ! tracer trend index + INTEGER , INTENT(in) :: kt ! time step 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( tsn, rab_PE, zpe ) + 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(:,:) = wn(:,:,1) * ( & + & - ( rab_n(:,:,1,jp_tem) + rab_pe(:,:,1,jp_tem) ) * tsn(:,:,1,jp_tem) & + & + ( rab_n(:,:,1,jp_sal) + rab_pe(:,:,1,jp_sal) ) * tsn(:,:,1,jp_sal) & + & ) / e3t_n(:,:,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) + !IF( ln_linssh ) THEN ! cst volume : ssh term (otherwise include in e3t variation) + ! ALLOCATE( z2d(jpi,jpj) ) + ! z2d(:,:) = ( ssha(:,:) - sshb(:,:) ) & + ! & * ( dPE_dt(:,:,1) * tsn(:,:,1,jp_tem) & + ! & + dPE_ds(:,:,1) * tsn(:,:,1,jp_sal) ) / ( e3t_n(:,:,1) * pdt ) + ! CALL iom_put( "petrd_sad" , z2d ) + ! DEALLOCATE( z2d ) + !ENDIF + ! + 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/NEMO_4.0.4_surge/src/OCE/TRD/trdtra.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdtra.F90 new file mode 100644 index 0000000..9175b6b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdtra.F90 @@ -0,0 +1,370 @@ +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(wp), 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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, ctype, ktra, ktrd, ptrd, pun, 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 + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: ptrd ! tracer trend or flux + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: pun ! now velocity + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in), OPTIONAL :: ptra ! now tracer variable + ! + INTEGER :: jk ! loop indices + INTEGER :: i01 ! 0 or 1 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: ztrds ! 3D workspace + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zwt, zws, 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' ) + ENDIF + ! + i01 = COUNT( (/ PRESENT(pun) .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, pun, ptra, 'X', trdtx ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'Y', trdty ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd, pun, ptra, 'Z', trdt ) + 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 ) + !!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 , pun , ptra, 'X' , ztrds ) + CALL trd_tra_mng( trdtx, ztrds, ktrd, kt ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Y' , ztrds ) + CALL trd_tra_mng( trdty, ztrds, ktrd, kt ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Z' , ztrds ) + CALL trd_tra_mng( trdt , ztrds, ktrd, kt ) + 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) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / e3w_n(:,:,jk) * tmask(:,:,jk) + zws(:,:,jk) = avs(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / e3w_n(:,:,jk) * tmask(:,:,jk) + END DO + ! + ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t_n(:,:,jk) + ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t_n(:,:,jk) + END DO + CALL trd_tra_mng( ztrdt, ztrds, jptra_zdfp, kt ) + ! + ! ! 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) * ( tsa(:,:,jk-1,jp_tem) - tsa(:,:,jk,jp_tem) ) / e3w_n(:,:,jk) * tmask(:,:,jk) + zws(:,:,jk) = avt_evd(:,:,jk) * ( tsa(:,:,jk-1,jp_sal) - tsa(:,:,jk,jp_sal) ) / e3w_n(:,:,jk) * tmask(:,:,jk) + END DO + ! + ztrdt(:,:,jpk) = 0._wp ; ztrds(:,:,jpk) = 0._wp + DO jk = 1, jpkm1 + ztrdt(:,:,jk) = ( zwt(:,:,jk) - zwt(:,:,jk+1) ) / e3t_n(:,:,jk) + ztrds(:,:,jk) = ( zws(:,:,jk) - zws(:,:,jk+1) ) / e3t_n(:,:,jk) + END DO + CALL trd_tra_mng( ztrdt, ztrds, jptra_evd, kt ) + ! + 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 ) + 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 , pun , ptra, 'X', ztrds ) + CASE( jptra_yad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Y', ztrds ) + CASE( jptra_zad ) ; CALL trd_tra_adv( ptrd , pun , ptra, 'Z', ztrds ) + CASE DEFAULT ! other trends: just masked + ztrds(:,:,:) = ptrd(:,:,:) * tmask(:,:,:) + END SELECT + ! ! send trend to trd_trc + CALL trd_trc( ztrds, ktra, ktrd, kt ) + ! + ENDIF + ! + END SUBROUTINE trd_tra + + + SUBROUTINE trd_tra_adv( pf, pun, ptn, cdir, ptrd ) + !!--------------------------------------------------------------------- + !! *** 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 ) :: pun ! now velocity in one direction + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: ptn ! now or before tracer + CHARACTER(len=1) , INTENT(in ) :: cdir ! X/Y/Z direction + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( out) :: ptrd ! advective trend in one direction + ! + 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 ! advective trend + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ptrd(ji,jj,jk) = - ( pf (ji,jj,jk) - pf (ji-ii,jj-ij,jk-ik) & + & - ( pun(ji,jj,jk) - pun(ji-ii,jj-ij,jk-ik) ) * ptn(ji,jj,jk) ) & + & * r1_e1e2t(ji,jj) / e3t_n(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 ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_mng *** + !! + !! ** Purpose : Dispatch all tracer trends computation, e.g. 3D output, + !! integral constraints, potential energy, and/or + !! mixed layer budget. + !!---------------------------------------------------------------------- + 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 + !!---------------------------------------------------------------------- + + IF( neuler == 0 .AND. kt == nit000 ) THEN ; r2dt = rdt ! = rdt (restart with Euler time stepping) + ELSEIF( kt <= nit000 + 1) THEN ; r2dt = 2. * rdt ! = 2 rdt (leapfrog) + ENDIF + + ! ! 3D output of tracers trends using IOM interface + IF( ln_tra_trd ) CALL trd_tra_iom ( ptrdx, ptrdy, ktrd, kt ) + + ! ! Integral Constraints Properties for tracers trends !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( ln_glo_trd ) CALL trd_glo( ptrdx, ptrdy, ktrd, 'TRA', kt ) + + ! ! Potential ENergy trends + IF( ln_PE_trd ) CALL trd_pen( ptrdx, ptrdy, ktrd, kt, r2dt ) + + ! ! 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, r2dt ) ! trends: Mixed-layer (output) + END SELECT + ! + ENDIF + ! + END SUBROUTINE trd_tra_mng + + + SUBROUTINE trd_tra_iom( ptrdx, ptrdy, ktrd, kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE trd_tra_iom *** + !! + !! ** Purpose : output 3D tracer trends using IOM + !!---------------------------------------------------------------------- + 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 + !! + 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(:,:) = wn(:,:,1) * tsn(:,:,1,jp_tem) / e3t_n(:,:,1) + z2dy(:,:) = wn(:,:,1) * tsn(:,:,1,jp_sal) / e3t_n(:,:,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/NEMO_4.0.4_surge/src/OCE/TRD/trdtrc.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdtrc.F90 new file mode 100644 index 0000000..55f7823 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdtrc.F90 @@ -0,0 +1,23 @@ +MODULE trdtrc + !!====================================================================== + !! *** MODULE trdtrc *** + !! Dummy module + !!====================================================================== + !!---------------------------------------------------------------------- + !! Dummy module NO TOP use + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE trd_trc( ptrtrd, kjn, ktrd, kt ) + INTEGER :: kt, kjn, ktrd + REAL :: 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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdtrc diff --git a/NEMO_4.0.4_surge/src/OCE/TRD/trdvor.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdvor.F90 new file mode 100644 index 0000000..3a31e9f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdvor.F90 @@ -0,0 +1,570 @@ +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(wp), SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: vortrd ! curl of trends + + CHARACTER(len=12) :: cvort + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: putrd, pvtrd ! U and V trends + INTEGER , INTENT(in ) :: ktrd ! trend index + INTEGER , INTENT(in ) :: kt ! time step + ! + INTEGER :: ji, jj ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: ztswu, ztswv ! 2D workspace + !!---------------------------------------------------------------------- + + SELECT CASE( ktrd ) + CASE( jpdyn_hpg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_prg ) ! Hydrostatique Pressure Gradient + CASE( jpdyn_keg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_keg ) ! KE Gradient + CASE( jpdyn_rvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_rvo ) ! Relative Vorticity + CASE( jpdyn_pvo ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_pvo ) ! Planetary Vorticity Term + CASE( jpdyn_ldf ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_ldf ) ! Horizontal Diffusion + CASE( jpdyn_zad ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_zad ) ! Vertical Advection + CASE( jpdyn_spg ) ; CALL trd_vor_zint( putrd, pvtrd, jpvor_spg ) ! Surface Pressure Grad. + CASE( jpdyn_zdf ) ! Vertical Diffusion + ztswu(:,:) = 0.e0 ; ztswv(:,:) = 0.e0 + DO jj = 2, jpjm1 ! wind stress trends + DO ji = fs_2, fs_jpim1 ! vector opt. + ztswu(ji,jj) = 0.5 * ( utau_b(ji,jj) + utau(ji,jj) ) / ( e3u_n(ji,jj,1) * rau0 ) + ztswv(ji,jj) = 0.5 * ( vtau_b(ji,jj) + vtau(ji,jj) ) / ( e3v_n(ji,jj,1) * rau0 ) + END DO + END DO + ! + CALL trd_vor_zint( putrd, pvtrd, jpvor_zdf ) ! zdf trend including surf./bot. stresses + CALL trd_vor_zint( ztswu, ztswv, jpvor_swf ) ! surface wind stress + CASE( jpdyn_bfr ) + CALL trd_vor_zint( putrd, pvtrd, jpvor_bfr ) ! Bottom stress + ! + CASE( jpdyn_atf ) ! last trends: perform the output of 2D vorticity trends + CALL trd_vor_iom( kt ) + END SELECT + ! + END SUBROUTINE trd_vor + + + SUBROUTINE trd_vor_zint_2d( putrdvor, pvtrdvor, ktrd ) + !!---------------------------------------------------------------------------- + !! *** 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 + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: putrdvor ! u vorticity trend + REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: 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 + !!---------------------------------------------------------------------- + + ! + + zudpvor(:,:) = 0._wp ; zvdpvor(:,:) = 0._wp ! Initialisation + CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1. ) ! lateral boundary condition + + + ! ===================================== + ! I vertical integration of 2D trends + ! ===================================== + + SELECT CASE( ktrd ) + ! + CASE( jpvor_bfr ) ! bottom friction + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + ikbu = mbkv(ji,jj) + ikbv = mbkv(ji,jj) + zudpvor(ji,jj) = putrdvor(ji,jj) * e3u_n(ji,jj,ikbu) * e1u(ji,jj) * umask(ji,jj,ikbu) + zvdpvor(ji,jj) = pvtrdvor(ji,jj) * e3v_n(ji,jj,ikbv) * e2v(ji,jj) * vmask(ji,jj,ikbv) + END DO + END DO + ! + CASE( jpvor_swf ) ! wind stress + zudpvor(:,:) = putrdvor(:,:) * e3u_n(:,:,1) * e1u(:,:) * umask(:,:,1) + zvdpvor(:,:) = pvtrdvor(:,:) * e3v_n(:,:,1) * e2v(:,:) * vmask(:,:,1) + ! + END SELECT + + ! Average except for Beta.V + zudpvor(:,:) = zudpvor(:,:) * r1_hu_n(:,:) + zvdpvor(:,:) = zvdpvor(:,:) * r1_hv_n(:,:) + + ! Curl + DO ji = 1, jpim1 + DO jj = 1, jpjm1 + vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) + END DO + END DO + vortrd(:,:,ktrd) = vortrd(:,:,ktrd) * fmask(:,:,1) ! Surface mask + + 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 ) + !!---------------------------------------------------------------------------- + !! *** 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 + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: putrdvor ! u vorticity trend + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pvtrdvor ! v vorticity trend + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj) :: zubet , zvbet ! Beta.V + REAL(wp), DIMENSION(jpi,jpj) :: zudpvor, zvdpvor ! total cmulative trends + !!---------------------------------------------------------------------- + + ! Initialization + zubet (:,:) = 0._wp + zvbet (:,:) = 0._wp + zudpvor(:,:) = 0._wp + zvdpvor(:,:) = 0._wp + ! ! lateral boundary condition on input momentum trends + CALL lbc_lnk_multi( 'trdvor', putrdvor, 'U', -1. , pvtrdvor, 'V', -1. ) + + ! ===================================== + ! I vertical integration of 3D trends + ! ===================================== + ! putrdvor and pvtrdvor terms + DO jk = 1,jpk + zudpvor(:,:) = zudpvor(:,:) + putrdvor(:,:,jk) * e3u_n(:,:,jk) * e1u(:,:) * umask(:,:,jk) + zvdpvor(:,:) = zvdpvor(:,:) + pvtrdvor(:,:,jk) * e3v_n(:,:,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 + zubet(:,:) = zudpvor(:,:) + zvbet(:,:) = zvdpvor(:,:) + DO ji = 1, jpim1 + DO jj = 1, jpjm1 + vortrd(ji,jj,jpvor_bev) = ( zvbet(ji+1,jj) - zvbet(ji,jj) & + & - ( zubet(ji,jj+1) - zubet(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) + END DO + END DO + ! Average of the Curl and Surface mask + vortrd(:,:,jpvor_bev) = vortrd(:,:,jpvor_bev) * r1_hu_n(:,:) * fmask(:,:,1) + ENDIF + ! + ! Average + zudpvor(:,:) = zudpvor(:,:) * r1_hu_n(:,:) + zvdpvor(:,:) = zvdpvor(:,:) * r1_hv_n(:,:) + ! + ! Curl + DO ji=1,jpim1 + DO jj=1,jpjm1 + vortrd(ji,jj,ktrd) = ( zvdpvor(ji+1,jj) - zvdpvor(ji,jj) & + & - ( zudpvor(ji,jj+1) - zudpvor(ji,jj) ) ) / ( e1f(ji,jj) * e2f(ji,jj) ) + END DO + END DO + ! Surface mask + vortrd(:,:,ktrd) = vortrd(:,:,ktrd) * fmask(:,:,1) + + 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 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE trd_vor *** + !! + !! ** Purpose : computation of cumulated trends over analysis period + !! and make outputs (NetCDF format) + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! time step + ! + INTEGER :: ji, jj, jk, jl ! dummy loop indices + INTEGER :: it, itmod ! local integers + REAL(wp) :: zmean ! local scalars + REAL(wp), DIMENSION(jpi,jpj) :: zun, zvn + !!---------------------------------------------------------------------- + + ! ================= + ! 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 + zun (:,:) = 0._wp + zvn (:,:) = 0._wp + vor_avrtot(:,:) = 0._wp + vor_avrres(:,:) = 0._wp + + ! Vertically averaged velocity + DO jk = 1, jpk - 1 + zun(:,:) = zun(:,:) + e1u(:,:) * un(:,:,jk) * e3u_n(:,:,jk) + zvn(:,:) = zvn(:,:) + e2v(:,:) * vn(:,:,jk) * e3v_n(:,:,jk) + END DO + + zun(:,:) = zun(:,:) * r1_hu_n(:,:) + zvn(:,:) = zvn(:,:) * r1_hv_n(:,:) + + ! Curl + DO ji = 1, jpim1 + DO jj = 1, jpjm1 + vor_avr(ji,jj) = ( ( zvn(ji+1,jj) - zvn(ji,jj) ) & + & - ( zun(ji,jj+1) - zun(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 * rdt ) + 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_multi( 'trdvor', vor_avrtot, 'F', 1. , vor_avrres, 'F', 1. ) + + + ! 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,vor_avrtot ,ndimvor1,ndexvor1) ! First membre + CALL histwrite( nidvor,"sovorgap",it,vor_avrres ,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(wp) :: 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 +#if defined key_diainstant + zsto = nn_write*rdt + clop = "inst("//TRIM(clop)//")" +#else + zsto = rdt + clop = "ave("//TRIM(clop)//")" +#endif + zout = nn_trd*rdt + + IF(lwp) WRITE(numout,*) ' netCDF initialization' + + ! II.2 Compute julian date from starting date of the run + ! ------------------------ + CALL ymds2ju( nyear, nmonth, nday, rdt, 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, glamf, jpj, gphif,1, jpi, & ! Horizontal grid : glamt and gphit + & 1, jpj, nit000-1, zjulian, rdt, 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/NEMO_4.0.4_surge/src/OCE/TRD/trdvor_oce.F90 b/NEMO_4.0.4_surge/src/OCE/TRD/trdvor_oce.F90 new file mode 100644 index 0000000..e56717a --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/TRD/trdvor_oce.F90 @@ -0,0 +1,34 @@ +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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE trdvor_oce diff --git a/NEMO_4.0.4_surge/src/OCE/USR/README.rst b/NEMO_4.0.4_surge/src/OCE/USR/README.rst new file mode 100644 index 0000000..d8817e0 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/USR/README.rst @@ -0,0 +1,280 @@ +****************************** +Setting up a new configuration +****************************** + +.. todo:: + + + +.. contents:: + :local: + +Starting from an existing configuration +======================================= + +There are three options to build a new configuration from an existing one. + +Option 1: Duplicate an existing configuration +--------------------------------------------- + +The NEMO so-called Reference Configurations cover a number of major features for NEMO setup +(global, regional, 1D, using embedded zoom with AGRIF...) + +One can create a new configuration by duplicating one of the reference configurations +(``ORCA2_ICE_PISCES`` in the following example) + +.. code-block:: console + + $ ./makenemo –n 'ORCA2_ICE_PISCES_MINE' -r 'ORCA2_ICE_PISCES' -m 'my_arch' + +Option 2: Duplicate with differences +------------------------------------ + +Create and compile a new configuration based on a reference configuration +(``ORCA2_ICE_PISCES`` in the following example) but with different pre-processor options. +For this either add ``add_key`` or ``del_key`` keys as required; e.g. + +.. code-block:: console + + $ ./makenemo –n 'ORCA2_ICE_PISCES_MINE' -r 'ORCA2_ICE_PISCES' -m 'my_arch' del_key 'key_iomput' add_key 'key_diahth' + +Option 3: Use the SIREN tools to subset an existing model +--------------------------------------------------------- + +Define a regional configuration which is a {sub,super}-set of an existing configuration. + +This last option employs the SIREN software tools that are included in the standard distribution. +The software is written in Fortran 95 and available in the :file:`./tools/SIREN` directory. +SIREN allows you to create your own regional configuration embedded in a wider one. + +SIREN is a set of programs to create all the input files you need to +run a NEMO regional configuration. + +:Demo: Set of GLORYS files (GLObal ReanalYSis on the ORCA025 grid), + as well as examples of namelists are available `here`_. +:Doc: :forge:`chrome/site/doc/SIREN/html/index.html` +:Support: Any questions or comments regarding the use of SIREN should be posted in + :forge:`the corresponding forum <discussion/forum/2>`. + +.. _here: https://prodn.idris.fr/thredds/catalog/ipsl_public/rron463/catalog.html + +Creating a completely new configuration +======================================= + +From NEMO version 4.0 there are two ways to build configurations from scratch. +The appropriate method to use depends largely on the target configuration. +Method 1 is for more complex/realistic global or regional configurations and +method 2 is intended for simpler, idealised configurations whose +domains and characteristics can be described in simple geometries and formulae. + +Option 1: Create and use a domain configuration file +---------------------------------------------------- + +This method is used by each of the reference configurations, +so that downloading their input files linked to their description can help. +Although starting from scratch, +it is advisable to create the directory structure to house your new configuration by +duplicating the closest reference configuration to your target application. +For example, if your application requires both ocean ice and passive tracers, +then use the ``ORCA2_ICE_PISCES`` as template, +and execute following command to build your ``MY_NEW_CONFIG`` configuration: + +.. code-block:: sh + + $ ./makenemo –n 'MY_NEW_CONFIG' -r 'ORCA2_ICE_PISCES' -m 'my_arch' + +where ``MY_NEW_CONFIG`` can be substituted with +a suitably descriptive name for your new configuration. + +The purpose of this step is simply to create and populate the appropriate :file:`WORK`, +:file:`MY_SRC` and :file:`EXP00` subdirectories for your new configuration. +Other choices for the base reference configuration might be + +:GYRE: If your target application is ocean-only +:AMM12: If your target application is regional with open boundaries + +All the domain information for your new configuration will be contained within +a netcdf file called :file:`domain_cfg.nc` which you will need to create and +place in the :file:`./cfgs/MY_NEW_CONFIG/EXP00` sub-directory. +Firstly though, ensure that your configuration is set to use such a file by checking that + +.. code-block:: fortran + + ln_read_cfg = .true. + +in :file:`./cfgs/MY_NEW_CONFIG/EXP00/namelist_cfg` + +Create the :file:`domain_cfg.nc` file which must contain the following fields + +.. code-block:: c + + /* configuration name, configuration resolution */ + int ORCA, ORCA_index + /* global domain sizes */ + int jpiglo, jpjglo, jpkglo + /* lateral global domain b.c. */ + int jperio + /* flags for z-coord, z-coord with partial steps and s-coord */ + int ln_zco, ln_zps, ln_sco + /* flag for ice shelf cavities */ + int ln_isfcav + /* geographic position */ + double glamt, glamu, glamv, glamf + /* geographic position */ + double gphit, gphiu, gphiv, gphif + /* Coriolis parameter (if not on the sphere) */ + double iff, ff_f, ff_t + /* horizontal scale factors */ + double e1t, e1u, e1v, e1f + /* horizontal scale factors */ + double e2t, e2u, e2v, e2f + /* U and V surfaces (if grid size reduction in some straits) */ + double ie1e2u_v, e1e2u, e1e2v + /* reference vertical scale factors at T and W points */ + double e3t_1d, e3w_1d + /* vertical scale factors 3D coordinate at T,U,V,F and W points */ + double e3t_0, e3u_0, e3v_0, e3f_0, e3w_0 + /* vertical scale factors 3D coordinate at UW and VW points */ + double e3uw_0, e3vw_0 + /* last wet T-points, 1st wet T-points (for ice shelf cavities) */ + int bottom_level, top_level + +There are two options for creating a :file:`domain_cfg.nc` file: + +- Users can use tools of their own choice to build a :file:`domain_cfg.nc` with all mandatory fields. +- Users can adapt and apply the supplied tool available in :file:`./tools/DOMAINcfg`. + This tool is based on code extracted from NEMO version 3.6 and will allow similar choices for + the horizontal and vertical grids that were available internally to that version. + See :ref:`tools <DOMAINcfg>` for details. + +Option 2: Adapt the usr_def configuration module of NEMO for you own purposes +----------------------------------------------------------------------------- + +This method is intended for configuring easily simple/idealised configurations which +are often used as demonstrators or for process evaluation and comparison. +This method can be used whenever the domain geometry has a simple mathematical description and +the ocean initial state and boundary forcing is described analytically. +As a start, consider the case of starting a completely new ocean-only test case based on +the ``LOCK_EXCHANGE`` example. + +.. note:: + + We probably need an even more basic example than this with only one namelist and + minimal changes to the usrdef modules + +Firstly, construct the directory structure, starting in the :file:`cfgs` directory: + +.. code-block:: console + + $ ./makenemo -n 'MY_NEW_TEST' -t 'LOCK_EXCHANGE' -m 'my_arch' + +where the ``-t`` option has been used to locate the new configuration in +the :file:`tests` subdirectory +(it is recommended practice to keep full configurations and idealised cases clearly distinguishable). +This command will create (amongst others) the following files and directories:: + + ./tests/MY_NEW_TEST: + BLD EXP00 MY_SRC WORK cpp_MY_NEW_TEST.fcm + + ./tests/MY_NEW_TEST/EXP00: + context_nemo.xml domain_def_nemo.xml field_def_nemo-oce.xml file_def_nemo-oce.xml iodef.xml + namelist_cfg namelist_ref + + ./tests/MY_NEW_TEST/MY_SRC: + usrdef_hgr.F90 usrdef_nam.F90 usrdef_zgr.F90 usrdef_istate.F90 usrdef_sbc.F90 zdfini.F90 + +The key to setting up an idealised configuration lies in +adapting a small set of short Fortran 90 modules which +should be dropped into the :file:`MY_SRC` directory. +Here the ``LOCK_EXCHANGE`` example is using 5 such routines but the full set that is available in +the :file:`src/OCE/USR` directory is:: + + ./src/OCE/USR: + usrdef_closea.F90 usrdef_fmask.F90 usrdef_hgr.F90 usrdef_istate.F90 + usrdef_nam.F90 usrdef_sbc.F90 usrdef_zgr.F90 + +Before discussing these in more detail it is worth noting the various namelist controls that +engage the different user-defined aspects. +These controls are set using two new logical switches or are implied by the settings of existing ones. +For example, the mandatory requirement for an idealised configuration is to provide routines which +define the horizontal and vertical domains. +Templates for these are provided in the :file:`usrdef_hgr.F90` and :file:`usrdef_zgr.F90` modules. +The application of these modules is activated whenever: + +.. code-block:: fortran + + ln_read_cfg = .false. + +in any configuration's :file:`namelist_cfg` file. +This setting also activates the reading of an optional ``&nam_usrdef`` namelist which can be used to +supply configuration specific settings. +These need to be declared and read in the :file:`usrdef_nam.F90` module. + +Another explicit control is available in the ``&namsbc`` namelist which +activates the use of analytical forcing. +With + +.. code-block:: fortran + + ln_usr = .true. + +Other usrdef modules are activated by less explicit means. +For example, code in :file:`usrdef_istate.F90` is used to +define initial temperature and salinity fields if + +.. code-block:: fortran + + ln_tsd_init = .false. + +in the ``&namtsd`` namelist. +The remaining modules, namely :file:`usrdef_closea.F90` :file:`usrdef_fmask.F90` are specific to +ORCA configurations and set local variations of some specific fields for +the various resolutions of the global models. +They do not need to be considered here in the context of idealised cases but +it is worth noting that all configuration specific code has now been isolated in the usrdef modules. +In the case of these last two modules, they are activated only if an ORCA configuration is detected. +Currently, +this requires a specific integer variable named ``ORCA`` to be set in a :file:`domain_cfg.nc` file. + +.. note:: + + This would be less confusing if the ``cn_cfg`` string is read directly as + a character attribue from the :file:`domain_cfg.nc`. + +So, in most cases, the set up of idealised model configurations can be completed by +copying the template routines from :file:`./src/OCE/USR` into +your new :file:`./cfgs/MY_NEW_TEST/MY_SRC` directory and +editing the appropriate modules as needed. +The default set are those used for the GYRE reference configuration. +The contents of :file:`MY_SRC` directories from other idealised configurations may provide +more convenient templates if they share common characteristics with your target application. + +Whatever the starting point, +it should not require too many changes or additional lines of code to produce routines in +:file:`./src/OCE/USR` that define analytically the domain, +the initial state and the surface boundary conditions for your new configuration. + +To summarize, the base set of modules is: + +:usrdef_hgr.F90: Define horizontal grid +:usrdef_zgr.F90: Define vertical grid +:usrdef_sbc.F90: Provides at each time-step the surface boundary condition, + i.e. the momentum, heat and freshwater fluxes +:usrdef_istate.F90: Defines initialization of the dynamics and tracers +:usrdef_nam.F90: Configuration-specific namelist processing to + set any associated run-time parameters + +with two specialised ORCA modules +(not related to idealised configurations but used to isolate configuration specific code that +is used in ORCA2 reference configurations and established global configurations using +the ORCA tripolar grid): + +:usrdef_fmask.F90: only used in ORCA configurations for + alteration of f-point land/ocean mask in some straits +:usrdef_closea.F90: only used in ORCA configurations for + specific treatments associated with closed seas + +From version 4.0, the NEMO release includes a :file:`tests` subdirectory containing available and +up to date :doc:`test cases <tests>` build by the community. +These will not be fully supported as are NEMO reference configurations, +but should provide a source of raw material. diff --git a/NEMO_4.0.4_surge/src/OCE/USR/usrdef_fmask.F90 b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_fmask.F90 new file mode 100644 index 0000000..7caef19 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_fmask.F90 @@ -0,0 +1,150 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 ; ij1 = 101 ! Gibraltar strait : partial slip (pfmsk=0.5) + ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ij0 = 102 ; ij1 = 102 + ii0 = 139 ; ii1 = 140 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 0.5_wp + ! + IF(lwp) WRITE(numout,*) ' Bab el Mandeb ' + ij0 = 87 ; ij1 = 88 ! Bab el Mandeb : partial slip (pfmsk=1) + ii0 = 160 ; ii1 = 160 ; pfmsk( mi0(ii0):mi1(ii1) , mj0(ij0):mj1(ij1) , 1:jpk ) = 1._wp + ij0 = 88 ; ij1 = 88 + ii0 = 159 ; ii1 = 159 ; 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 - jpjglo + ! + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) ' orca_r1: increase friction near the following straits : ' + IF(lwp) WRITE(numout,*) ' Gibraltar ' + ii0 = 282 ; ii1 = 283 ! Gibraltar Strait + ij0 = 241 - isrow ; ij1 = 241 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Bhosporus ' + ii0 = 314 ; ii1 = 315 ! Bhosporus Strait + ij0 = 248 - isrow ; ij1 = 248 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Makassar (Top) ' + ii0 = 48 ; ii1 = 48 ! Makassar Strait (Top) + ij0 = 189 - isrow ; ij1 = 190 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + IF(lwp) WRITE(numout,*) ' Lombok ' + ii0 = 44 ; ii1 = 44 ! Lombok Strait + ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Ombai ' + ii0 = 53 ; ii1 = 53 ! Ombai Strait + ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' Timor Passage ' + ii0 = 56 ; ii1 = 56 ! Timor Passage + ij0 = 164 - isrow ; ij1 = 165 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 2._wp + ! + IF(lwp) WRITE(numout,*) ' West Halmahera ' + ii0 = 58 ; ii1 = 58 ! West Halmahera Strait + ij0 = 181 - isrow ; ij1 = 182 - isrow ; pfmsk( mi0(ii0):mi1(ii1),mj0(ij0):mj1(ij1),1:jpk ) = 3._wp + ! + IF(lwp) WRITE(numout,*) ' East Halmahera ' + ii0 = 55 ; ii1 = 55 ! East Halmahera Strait + ij0 = 181 - isrow ; ij1 = 182 - 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/NEMO_4.0.4_surge/src/OCE/USR/usrdef_hgr.F90 b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_hgr.F90 new file mode 100644 index 0000000..70ed3ba --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_hgr.F90 @@ -0,0 +1,172 @@ +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 , ONLY: nimpp, njmpp ! 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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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) :: pe1t, pe1u, pe1v, pe1f ! i-scale factors [m] + REAL(wp), DIMENSION(:,:), INTENT(out) :: pe2t, pe2u, 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( jpjglo-2 , wp ) + zphi0 = zphi1 + zsin_alpha * ze1deg * REAL( jpjglo-2 , wp ) + +#if defined key_agrif + ! ! Upper left longitude and latitude from parent: + IF (.NOT.Agrif_root()) THEN + zlam0 = zlam1 + Agrif_irhox() * REAL(Agrif_Parent(jpjglo)-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(jpjglo)-2 , wp) * ze1deg * zsin_alpha & + & - ( Agrif_Ix()*Agrif_irhox()-nbghostcells ) * ze1deg * zsin_alpha & + & + ( Agrif_Iy()*Agrif_irhoy()-nbghostcells ) * ze1deg * zcos_alpha + ENDIF +#endif + ! + 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 rdt, ahm,aht ' ) + ENDIF + IF( nprint==1 .AND. lwp ) THEN + WRITE(numout,*) 'ze1', ze1, 'cosalpha', zcos_alpha, 'sinalpha', zsin_alpha + WRITE(numout,*) 'ze1deg', ze1deg, 'zlam0', zlam0, 'zphi0', zphi0 + ENDIF + ! + DO jj = 1, jpj + DO ji = 1, jpi + zim1 = REAL( ji + nimpp - 1 ) - 1. ; zim05 = REAL( ji + nimpp - 1 ) - 1.5 + zjm1 = REAL( jj + njmpp - 1 ) - 1. ; zjm05 = REAL( jj + njmpp - 1 ) - 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/MY_SRC/.svn/text-base/usrdef_istate.F90.svn-base b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_istate.F90 similarity index 53% rename from MY_SRC/.svn/text-base/usrdef_istate.F90.svn-base rename to NEMO_4.0.4_surge/src/OCE/USR/usrdef_istate.F90 index bf4eeac..3defb6a 100644 --- a/MY_SRC/.svn/text-base/usrdef_istate.F90.svn-base +++ b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_istate.F90 @@ -1,19 +1,18 @@ MODULE usrdef_istate !!====================================================================== - !! *** MODULE usrdef_istate *** + !! *** MODULE usrdef_istate *** !! - !! === Constant TS configuration === + !! === GYRE configuration === !! !! User defined : set the initial state of a user configuration !!====================================================================== - !! History : NEMO ! 2016-03 (S. Flavoni, G. Madec) Original code + !! History : 4.0 ! 2016-03 (S. Flavoni) Original code !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- !! usr_def_istate : initial state in Temperature and salinity !!---------------------------------------------------------------------- USE par_oce ! ocean space and time domain - USE dom_oce , ONLY : glamt USE phycst ! physical constants ! USE in_out_manager ! I/O manager @@ -22,12 +21,12 @@ MODULE usrdef_istate IMPLICIT NONE PRIVATE - PUBLIC usr_def_istate ! called by istate.F90 + PUBLIC usr_def_istate ! called in istate.F90 !!---------------------------------------------------------------------- - !! NEMO/OPA 4.0 , NEMO Consortium (2016) - !! $Id$ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -36,8 +35,7 @@ SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) !! *** ROUTINE usr_def_istate *** !! !! ** Purpose : Initialization of the dynamics and tracers - !! Set a constant T&S, to use for testing when ln_2d=False - !! (when it is True, T&S are automatically set to 0) + !! Here GYRE configuration example : (double gyre with rotated domain) !! !! ** Method : - set temprature field !! - set salinity field @@ -49,27 +47,37 @@ SUBROUTINE usr_def_istate( pdept, ptmask, pts, pu, pv, pssh ) REAL(wp), DIMENSION(jpi,jpj,jpk) , INTENT( out) :: pv ! j-component of the velocity [m/s] REAL(wp), DIMENSION(jpi,jpj) , INTENT( out) :: pssh ! sea-surface height ! - INTEGER :: jk ! dummy loop indices - REAL(wp) :: zdam ! location of dam [Km] + INTEGER :: ji, jj, jk ! dummy loop indices !!---------------------------------------------------------------------- ! IF(lwp) WRITE(numout,*) - IF(lwp) WRITE(numout,*) 'usr_def_istate : ' - IF(lwp) WRITE(numout,*) '~~~~~~~~~~~~~~ Ocean at rest, with a constant temperature and salinity' - - ! - ! rn_a0 = 0.2 ! thermal expension coefficient (nn_eos= 1) - ! rho = rau0 - rn_a0 * (T-10) - ! delta_T = 25 degrees ==>> delta_rho = 25 * rn_a0 = 5 kg/m3 + 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 pssh(:,:) = 0._wp ! - ! ! T & S profiles - zdam = 32. ! density front position in kilometers - pts(:,:,:,jp_tem) = 10._wp * ptmask(:,:,:) - pts(:,:,:,jp_sal) = 35._wp * ptmask(:,:,:) + DO jk = 1, jpk ! horizontally uniform T & S profiles + DO jj = 1, jpj + DO ji = 1, jpi + 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 diff --git a/NEMO_4.0.4_surge/src/OCE/USR/usrdef_nam.F90 b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_nam.F90 new file mode 100644 index 0000000..fdba523 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_nam.F90 @@ -0,0 +1,109 @@ +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 , ONLY: nimpp, njmpp ! ocean space and time domain + 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$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usr_def_nam( cd_cfg, kk_cfg, kpi, kpj, kpk, kperio ) + !!---------------------------------------------------------------------- + !! *** 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 + INTEGER , INTENT(out) :: kperio ! lateral global domain b.c. + ! + INTEGER :: ios ! Local integer + !! + NAMELIST/namusr_def/ nn_GYRE, ln_bench, jpkglo + !!---------------------------------------------------------------------- + ! + REWIND( numnam_cfg ) ! Namelist namusr_def (exist in namelist_cfg only) + 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) +#if defined key_agrif + IF (.NOT.Agrif_root()) nn_GYRE = Agrif_parent(nn_GYRE) * Agrif_irhox() +#endif + kk_cfg = nn_GYRE + ! + kpi = 30 * nn_GYRE + 2 ! Global Domain size + kpj = 20 * nn_GYRE + 2 +#if defined key_agrif + IF( .NOT. Agrif_Root() ) THEN + kpi = nbcellsx + 2 + 2*nbghostcells + kpj = nbcellsy + 2 + 2*nbghostcells + ENDIF +#endif + kpk = jpkglo + ! ! Set the lateral boundary condition of the global domain + kperio = 0 ! GYRE configuration : closed domain + ! + ! ! 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 +#if defined key_agrif + IF( Agrif_Root() ) THEN +#endif + WRITE(numout,*) ' jpiglo = 30*nn_GYRE+2 jpiglo = ', kpi + WRITE(numout,*) ' jpjglo = 20*nn_GYRE+2 jpjglo = ', kpj +#if defined key_agrif + ENDIF +#endif + WRITE(numout,*) ' number of model levels jpkglo = ', kpk + WRITE(numout,*) ' ' + WRITE(numout,*) ' Lateral b.c. of the global domain set to closed jperio = ', kperio + ENDIF + ! + END SUBROUTINE usr_def_nam + + !!====================================================================== +END MODULE usrdef_nam diff --git a/NEMO_4.0.4_surge/src/OCE/USR/usrdef_sbc.F90 b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_sbc.F90 new file mode 100644 index 0000000..c25a337 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_sbc.F90 @@ -0,0 +1,100 @@ +MODULE usrdef_sbc + !!====================================================================== + !! *** MODULE usrdef_sbc *** + !! + !! + !! + !! User defined : set all surface forcing to 0 + !!====================================================================== + !! History : 4.0 ! 2016-03 (S. Flavoni, G. Madec) user defined interface + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! usrdef_sbc : user defined surface bounday conditions + !!---------------------------------------------------------------------- + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE usrdef_sbc_oce( kt ) + !!--------------------------------------------------------------------- + !! *** ROUTINE usrdef_sbc *** + !! + !! ** Purpose : provide at each time-step the surface boundary + !! condition, i.e. the momentum, heat and freshwater fluxes. + !! + !! ** Method : Set all surface forcing to 0 + !! ** Action : - set the ocean surface boundary condition, i.e. + !! utau, vtau, taum, wndm, qns, qsr, emp, sfx + !! + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time step + + ! ---------------------------- ! + ! heat and freshwater fluxes ! + ! ---------------------------- ! + + ! freshwater (mass flux) and update of qns with heat content of emp + emp (:,:) = 0.0_wp ! freshwater flux + sfx (:,:) = 0.0_wp ! no salt flux + qns (:,:) = 0.0_wp ! non solar heat flux + qsr (:,:) = 0.0_wp ! solar heat flux + + + ! ---------------------------- ! + ! momentum fluxes ! + ! ---------------------------- ! + utau(:,:) = 0.0_wp + vtau(:,:) = 0.0_wp + taum(:,:) = 0.0_wp + wndm(:,:) = 0.0_wp + CALL lbc_lnk_multi( 'usrdef_sbc', taum(:,:), 'T', 1. , wndm(:,:), 'T', 1. ) + + ! ---------------------------------- ! + ! control print at first time-step ! + ! ---------------------------------- ! + IF( kt == nit000 .AND. lwp ) THEN + WRITE(numout,*) + WRITE(numout,*)'usrdef_sbc_oce : all surface fluxes set to 0' + WRITE(numout,*)'~~~~~~~~~~~ ' + + 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/NEMO_4.0.4_surge/src/OCE/USR/usrdef_zgr.F90 b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_zgr.F90 new file mode 100644 index 0000000..596df9e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/USR/usrdef_zgr.F90 @@ -0,0 +1,248 @@ +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 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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) :: pe3t , pe3u , pe3v , pe3f ! 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 + ! + CALL lbc_lnk( 'usrdef_zgr', z2d, 'T', 1. ) ! set surrounding land to zero (here jperio=0 ==>> closed) + ! + 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) :: pe3t , pe3u , pe3v , pe3f ! 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/NEMO_4.0.4_surge/src/OCE/ZDF/zdf_oce.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdf_oce.F90 new file mode 100644 index 0000000..0cb3078 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdf_oce.F90 @@ -0,0 +1,76 @@ +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 + ! ! 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$ + !! 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/NEMO_4.0.4_surge/src/OCE/ZDF/zdfddm.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfddm.F90 new file mode 100644 index 0000000..b1289e7 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfddm.F90 @@ -0,0 +1,172 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_ddm( kt, 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 indexocean time step + 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, zrr ! - - + REAL(wp) :: zavft, zavfs ! - - + REAL(wp) :: zavdt, zavds ! - - + REAL(wp), DIMENSION(jpi,jpj) :: 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 = 1, jpj !== R=zrau = (alpha / beta) (dk[t] / dk[s]) ==! + DO ji = 1, jpi + zrw = ( gdepw_n(ji,jj,jk ) - gdept_n(ji,jj,jk) ) & +!!gm please, use e3w_n below + & / ( gdept_n(ji,jj,jk-1) - gdept_n(ji,jj,jk) ) + ! + 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 * ( tsn(ji,jj,jk-1,jp_tem) - tsn(ji,jj,jk,jp_tem) ) + zds = zbw * ( tsn(ji,jj,jk-1,jp_sal) - tsn(ji,jj,jk,jp_sal) ) + 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 = 1, jpj !== indicators ==! + DO ji = 1, jpi + ! 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 + 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 + ! mask zmsk in order to have avt and avs masked + zmsks(:,:) = zmsks(:,:) * wmask(:,:,jk) + + + ! Update avt and avs + ! ------------------ + ! Constant eddy coefficient: reset to the background value + DO jj = 1, jpj + DO ji = 1, jpi + 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(ln_ctl) THEN + CALL prt_ctl(tab3d_1=avt , clinfo1=' ddm - t: ', tab3d_2=avs , clinfo2=' s: ', kdim=jpk) + ENDIF + ! + END SUBROUTINE zdf_ddm + + !!====================================================================== +END MODULE zdfddm diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfdrg.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfdrg.F90 new file mode 100644 index 0000000..3ea5e30 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfdrg.F90 @@ -0,0 +1,466 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_drg( kt, 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 + ! ! !! !== 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 = 2, jpjm1 + DO ji = 2, jpim1 + imk = k_mk(ji,jj) ! ocean bottom level at t-points + zut = un(ji,jj,imk) + un(ji-1,jj,imk) ! 2 x velocity at t-point + zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk) + zzz = 0.5_wp * e3t_n(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 = 2, jpjm1 + DO ji = 2, jpim1 + imk = k_mk(ji,jj) ! ocean bottom level at t-points + zut = un(ji,jj,imk) + un(ji-1,jj,imk) ! 2 x velocity at t-point + zvt = vn(ji,jj,imk) + vn(ji,jj-1,imk) + ! ! 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(ln_ctl) CALL prt_ctl( tab2d_1=pCdU, clinfo1=' Cd*U ') + ! + END SUBROUTINE zdf_drg + + + SUBROUTINE zdf_drg_exp( kt, 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 + REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pub, pvb ! the two components of the before velocity + REAL(wp), 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(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdu, ztrdv + !!--------------------------------------------------------------------- + ! +!!gm bug : time step is only rdt (not 2 rdt if euler start !) + zm1_2dt = - 1._wp / ( 2._wp * rdt ) + + 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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_n(ji,jj,ikbu) + zCdv = 0.5*( rCdU_bot(ji,jj+1)+rCdU_bot(ji,jj) ) / e3v_n(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 = 2, jpjm1 + DO ji = 2, jpim1 + 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_n(ji,jj,ikbu) ! NB: Cdtop masked + zCdv = 0.5*( rCdU_top(ji,jj+1)+rCdU_top(ji,jj) ) / e3v_n(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 ) + DEALLOCATE( ztrdu, ztrdv ) + ENDIF + ! ! print mean trends (used for debugging) + IF(ln_ctl) 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 ==! + ! + REWIND( numnam_ref ) ! Namelist namdrg in reference namelist + READ ( numnam_ref, namdrg, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam( ios , 'namdrg in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namdrg in configuration 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 ==! + ! + REWIND( numnam_ref ) ! Namelist cl_namdrg in reference namelist + 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) ) + REWIND( numnam_cfg ) ! Namelist cd_namdrg in configuration namelist + 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_data, 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 + ! + ! + 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 = 1, jpj ! pCd0 = mask (and boosted) logarithmic drag coef. + DO ji = 1, jpi + 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/NEMO_4.0.4_surge/src/OCE/ZDF/zdfevd.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfevd.F90 new file mode 100644 index 0000000..e41d510 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfevd.F90 @@ -0,0 +1,124 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_evd( kt, 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 + REAL(wp), DIMENSION(:,:,:) , INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop indices + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zavt_evd, zavm_evd + !!---------------------------------------------------------------------- + ! + 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 + ! + ! + zavt_evd(:,:,:) = p_avt(:,:,:) ! set avt prior to evd application + ! + SELECT CASE ( nn_evdm ) + ! + CASE ( 1 ) !== enhance tracer & momentum Kz ==! (if rn2<-1.e-12) + ! + zavm_evd(:,:,:) = p_avm(:,:,:) ! set avm prior to evd application + ! +!! 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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 + ! + zavm_evd(:,:,:) = p_avm(:,:,:) - zavm_evd(:,:,:) ! change in avm due to evd + CALL iom_put( "avm_evd", zavm_evd ) ! output this change + ! + 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 = 2, jpjm1 + DO ji = 2, jpim1 + 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 + ! + zavt_evd(:,:,:) = p_avt(:,:,:) - zavt_evd(:,:,:) ! change in avt due to evd + CALL iom_put( "avt_evd", zavt_evd ) ! output this change + IF( l_trdtra ) CALL trd_tra( kt, 'TRA', jp_tem, jptra_evd, zavt_evd ) + ! + END SUBROUTINE zdf_evd + + !!====================================================================== +END MODULE zdfevd diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfgls.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfgls.F90 new file mode 100644 index 0000000..43a8a62 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfgls.F90 @@ -0,0 +1,1242 @@ +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_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 <rl_sf<vkarmn + REAL(wp) :: rghmin = -0.28_wp + REAL(wp) :: rgh0 = 0.0329_wp + REAL(wp) :: rghcri = 0.03_wp + REAL(wp) :: ra1 = 0.92_wp + REAL(wp) :: ra2 = 0.74_wp + REAL(wp) :: rb1 = 16.60_wp + REAL(wp) :: rb2 = 10.10_wp + REAL(wp) :: re2 = 1.33_wp + REAL(wp) :: rl1 = 0.107_wp + REAL(wp) :: rl2 = 0.0032_wp + REAL(wp) :: rl3 = 0.0864_wp + REAL(wp) :: rl4 = 0.12_wp + REAL(wp) :: rl5 = 11.9_wp + REAL(wp) :: rl6 = 0.4_wp + REAL(wp) :: rl7 = 0.0_wp + REAL(wp) :: rl8 = 0.48_wp + REAL(wp) :: rm1 = 0.127_wp + REAL(wp) :: rm2 = 0.00336_wp + REAL(wp) :: rm3 = 0.0906_wp + REAL(wp) :: rm4 = 0.101_wp + REAL(wp) :: rm5 = 11.2_wp + REAL(wp) :: rm6 = 0.4_wp + REAL(wp) :: rm7 = 0.0_wp + REAL(wp) :: rm8 = 0.318_wp + REAL(wp) :: rtrans = 0.1_wp + REAL(wp) :: rc02, rc02r, rc03, rc04 ! coefficients deduced from above parameters + REAL(wp) :: rsbc_tke1, rsbc_tke2, rfact_tke ! - - - - + REAL(wp) :: rsbc_psi1, rsbc_psi2, rfact_psi ! - - - - + REAL(wp) :: rsbc_zs1, rsbc_zs2 ! - - - - + REAL(wp) :: rc0, rc2, rc3, rf6, rcff, rc_diff ! - - - - + REAL(wp) :: rs0, rs1, rs2, rs4, rs5, rs6 ! - - - - + REAL(wp) :: rd0, rd1, rd2, rd3, rd4, rd5 ! - - - - + REAL(wp) :: rsc_tke, rsc_psi, rpsi1, rpsi2, rpsi3, rsc_psi0 ! - - - - + REAL(wp) :: rpsi3m, rpsi3p, rpp, rmm, rnn ! - - - - + ! + REAL(wp) :: r2_3 = 2._wp/3._wp ! constant=2/3 + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_gls_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_gls_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( hmxl_n(jpi,jpj,jpk) , ustar2_surf(jpi,jpj) , & + & zwall (jpi,jpj,jpk) , ustar2_top (jpi,jpj) , ustar2_bot(jpi,jpj) , STAT= zdf_gls_alloc ) + ! + CALL mpp_sum ( 'zdfgls', zdf_gls_alloc ) + IF( zdf_gls_alloc /= 0 ) CALL ctl_stop( 'STOP', 'zdf_gls_alloc: failed to allocate arrays' ) + END FUNCTION zdf_gls_alloc + + + SUBROUTINE zdf_gls( kt, p_sh2, p_avm, p_avt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_gls *** + !! + !! ** Purpose : Compute the vertical eddy viscosity and diffusivity + !! coefficients using the GLS turbulent closure scheme. + !!---------------------------------------------------------------------- + USE zdf_oce , ONLY : en, avtb, avmb ! ocean vertical physics + !! + INTEGER , INTENT(in ) :: kt ! ocean time step + REAL(wp), DIMENSION(:,:,:), 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 arguments + INTEGER :: ibot, ibotm1 ! local integers + INTEGER :: itop, itopp1 ! - - + REAL(wp) :: zesh2, zsigpsi, zcoef, zex1 , zex2 ! local scalars + REAL(wp) :: ztx2, zty2, zup, zdown, zcof, zdir ! - - + REAL(wp) :: zratio, zrn2, zflxb, sh , z_en ! - - + REAL(wp) :: prod, buoy, diss, zdiss, sm ! - - + REAL(wp) :: gh, gm, shr, dif, zsqen, zavt, zavm ! - - + REAL(wp) :: zmsku, zmskv ! - - + REAL(wp), DIMENSION(jpi,jpj) :: zdep + REAL(wp), DIMENSION(jpi,jpj) :: zkar + REAL(wp), DIMENSION(jpi,jpj) :: zflxs ! Turbulence fluxed induced by internal waves + REAL(wp), DIMENSION(jpi,jpj) :: zhsro ! Surface roughness (surface waves) + REAL(wp), DIMENSION(jpi,jpj) :: zice_fra ! Tapering of wave breaking under sea ice + REAL(wp), DIMENSION(jpi,jpj,jpk) :: eb ! tke at time before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: hmxl_b ! mixing length at time before + REAL(wp), DIMENSION(jpi,jpj,jpk) :: eps ! dissipation rate + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwall_psi ! Wall function use in the wb case (ln_sigpsi) + REAL(wp), DIMENSION(jpi,jpj,jpk) :: psi ! psi at time now + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zd_lw, zd_up, zdiag ! lower, upper and diagonal of the matrix + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zstt, zstm ! stability function on tracer and momentum + !!-------------------------------------------------------------------- + ! + ! Preliminary computing + + ustar2_surf(:,:) = 0._wp ; psi(:,:,:) = 0._wp + ustar2_top (:,:) = 0._wp ; zwall_psi(:,:,:) = 0._wp + ustar2_bot (:,:) = 0._wp + + SELECT CASE ( nn_z0_ice ) + CASE( 0 ) ; zice_fra(:,:) = 0._wp + CASE( 1 ) ; zice_fra(:,:) = TANH( fr_i(:,:) * 10._wp ) + CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:) + CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) + END SELECT + + ! Compute surface, top and bottom friction at T-points + DO jj = 2, jpjm1 !== surface ocean friction + DO ji = fs_2, fs_jpim1 ! vector opt. + ustar2_surf(ji,jj) = r1_rau0 * taum(ji,jj) * tmask(ji,jj,1) + END DO + END DO + ! +!!gm Rq we may add here r_ke0(_top/_bot) ? ==>> think about that... + ! + IF( .NOT.ln_drg_OFF ) THEN !== top/bottom friction (explicit before friction) + DO jj = 2, jpjm1 ! bottom friction + DO ji = fs_2, fs_jpim1 ! vector opt. + zmsku = 0.5*( 2._wp - umask(ji-1,jj,mbkt(ji,jj)) * umask(ji,jj,mbkt(ji,jj)) ) + zmskv = 0.5*( 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*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2 & + & + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2 ) + END DO + END DO + IF( ln_isfcav ) THEN !top friction + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zmsku = ( 2._wp - umask(ji-1,jj,mikt(ji,jj)) * umask(ji,jj,mikt(ji,jj)) ) + zmskv = ( 2._wp - 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*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2 & + & + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**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 + zhsro(:,:) = MAX( rsbc_zs1 * ustar2_surf(:,:) , rn_hsro ) + 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) + zdep (:,:) = 30.*TANH( 2.*0.3/(28.*SQRT(MAX(ustar2_surf(:,:),rsmall))) ) ! Wave age (eq. 10) + zhsro(:,:) = MAX(rsbc_zs2 * ustar2_surf(:,:) * zdep(:,:)**1.5, rn_hsro) ! zhsro = rn_frac_hs * Hsw (eq. 11) + CASE ( 3 ) ! Roughness given by the wave model (coupled or read in file) + zhsro(:,:) = MAX(rn_frac_hs * hsw(:,:), rn_hsro) ! (rn_frac_hs=1.6 see Eq. (5) of Rascle et al. 2008 ) + END SELECT + ! + ! adapt roughness where there is sea ice + zhsro(:,:) = ( (1._wp-zice_fra(:,:)) * zhsro(:,:) + zice_fra(:,:) * rn_hsri )*tmask(:,:,1) + (1._wp - tmask(:,:,1))*rn_hsro + ! + DO jk = 2, jpkm1 !== Compute dissipation rate ==! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + 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 + eb (:,:,:) = en (:,:,:) + hmxl_b(:,:,:) = hmxl_n(:,:,:) + + IF( nn_clos == 0 ) THEN ! Mellor-Yamada + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zup = hmxl_n(ji,jj,jk) * gdepw_n(ji,jj,mbkt(ji,jj)+1) + zdown = vkarmn * gdepw_n(ji,jj,jk) * ( -gdepw_n(ji,jj,jk) + gdepw_n(ji,jj,mbkt(ji,jj)+1) ) + 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 = 2, jpjm1 + DO ji = 2, jpim1 + ! + 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_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) + ! ! 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_n(ji,jj,jk ) * e3w_n(ji,jj,jk) ) + ! ! diagonal + zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) + ! ! right hand side in en + en(ji,jj,jk) = en(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + zdiag(:,:,jpk) = 1._wp + ! + ! Set surface condition on zwall_psi (1 at the bottom) + zwall_psi(:,:, 1 ) = zwall_psi(:,:,2) + zwall_psi(:,:,jpk) = 1._wp + ! + ! Surface boundary condition on tke + ! --------------------------------- + ! + SELECT CASE ( nn_bc_surf ) + ! + CASE ( 0 ) ! Dirichlet boundary condition (set e at k=1 & 2) + ! First level + en (:,:,1) = MAX( rn_emin , rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 ) + zd_lw(:,:,1) = en(:,:,1) + zd_up(:,:,1) = 0._wp + zdiag(:,:,1) = 1._wp + ! + ! One level below + en (:,:,2) = MAX( rc02r * ustar2_surf(:,:) * ( 1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1 * ((zhsro(:,:)+gdepw_n(:,:,2)) & + & / zhsro(:,:) )**(1.5_wp*ra_sf) )**(2._wp/3._wp) , rn_emin ) + zd_lw(:,:,2) = 0._wp + zd_up(:,:,2) = 0._wp + zdiag(:,:,2) = 1._wp + ! + ! + CASE ( 1 ) ! Neumann boundary condition (set d(e)/dz) + ! + ! Dirichlet conditions at k=1 + en (:,:,1) = MAX( rc02r * ustar2_surf(:,:) * (1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1)**r2_3 , rn_emin ) + zd_lw(:,:,1) = en(:,:,1) + zd_up(:,:,1) = 0._wp + zdiag(:,:,1) = 1._wp + ! + ! at k=2, set de/dz=Fw + !cbr + zdiag(:,:,2) = zdiag(:,:,2) + zd_lw(:,:,2) ! Remove zd_lw from zdiag + zd_lw(:,:,2) = 0._wp + zkar (:,:) = (rl_sf + (vkarmn-rl_sf)*(1.-EXP(-rtrans*gdept_n(:,:,1)/zhsro(:,:)) )) + zflxs(:,:) = rsbc_tke2 * (1._wp-zice_fra(:,:)) * ustar2_surf(:,:)**1.5_wp * zkar(:,:) & + & * ( ( zhsro(:,:)+gdept_n(:,:,1) ) / zhsro(:,:) )**(1.5_wp*ra_sf) +!!gm why not : * ( 1._wp + gdept_n(:,:,1) / zhsro(:,:) )**(1.5_wp*ra_sf) + en(:,:,2) = en(:,:,2) + zflxs(:,:) / e3w_n(:,:,2) + ! + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. +!!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 + ! + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ) + +!CEOD This is not set in default code .. bug. + en(ji,jj,ibot) = 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 + END DO + END DO + IF( ln_isfcav) THEN ! top boundary (ocean cavity) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + END DO + END DO + ENDIF + ! + END SELECT + + ! Matrix inversion (en prescribed at surface and the bottom) + ! ---------------------------------------------------------- + ! + DO jk = 2, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + en(:,:,:) = MAX( en(:,:,:), rn_emin ) + + !!----------------------------------------!! + !! 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + psi(ji,jj,jk) = eps(ji,jj,jk) + END DO + END DO + END DO + ! + CASE( 2 ) ! k-w + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! + ! 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_n(ji,jj,jk-1) * e3w_n(ji,jj,jk) ) + ! ! upper diagonal + zd_up(ji,jj,jk) = zcof * ( p_avm(ji,jj,jk+1) + p_avm(ji,jj,jk ) ) / ( e3t_n(ji,jj,jk ) * e3w_n(ji,jj,jk) ) + ! ! diagonal + zdiag(ji,jj,jk) = 1._wp - zd_lw(ji,jj,jk) - zd_up(ji,jj,jk) + rdt * zdiss * wmask(ji,jj,jk) + ! ! right hand side in psi + psi(ji,jj,jk) = psi(ji,jj,jk) + rdt * zesh2 * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + zdiag(:,:,jpk) = 1._wp + + ! Surface boundary condition on psi + ! --------------------------------- + ! + SELECT CASE ( nn_bc_surf ) + ! + CASE ( 0 ) ! Dirichlet boundary conditions + ! + ! Surface value + zdep (:,:) = zhsro(:,:) * rl_sf ! Cosmetic + psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) + zd_lw(:,:,1) = psi(:,:,1) + zd_up(:,:,1) = 0._wp + zdiag(:,:,1) = 1._wp + ! + ! One level below + zkar (:,:) = (rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdepw_n(:,:,2)/zhsro(:,:) ))) + zdep (:,:) = (zhsro(:,:) + gdepw_n(:,:,2)) * zkar(:,:) + psi (:,:,2) = rc0**rpp * en(:,:,2)**rmm * zdep(:,:)**rnn * tmask(:,:,1) + zd_lw(:,:,2) = 0._wp + zd_up(:,:,2) = 0._wp + zdiag(:,:,2) = 1._wp + ! + CASE ( 1 ) ! Neumann boundary condition on d(psi)/dz + ! + ! Surface value: Dirichlet + zdep (:,:) = zhsro(:,:) * rl_sf + psi (:,:,1) = rc0**rpp * en(:,:,1)**rmm * zdep(:,:)**rnn * tmask(:,:,1) + zd_lw(:,:,1) = psi(:,:,1) + zd_up(:,:,1) = 0._wp + zdiag(:,:,1) = 1._wp + ! + ! Neumann condition at k=2 + zdiag(:,:,2) = zdiag(:,:,2) + zd_lw(:,:,2) ! Remove zd_lw from zdiag + zd_lw(:,:,2) = 0._wp + ! + ! Set psi vertical flux at the surface: + zkar (:,:) = rl_sf + (vkarmn-rl_sf)*(1._wp-EXP(-rtrans*gdept_n(:,:,1)/zhsro(:,:) )) ! Lengh scale slope + zdep (:,:) = ((zhsro(:,:) + gdept_n(:,:,1)) / zhsro(:,:))**(rmm*ra_sf) + zflxs(:,:) = (rnn + (1._wp-zice_fra(:,:))*rsbc_tke1 * (rnn + rmm*ra_sf) * zdep(:,:)) & + & *(1._wp + (1._wp-zice_fra(:,:))*rsbc_tke1*zdep(:,:))**(2._wp*rmm/3._wp-1_wp) + zdep (:,:) = rsbc_psi1 * (zwall_psi(:,:,1)*p_avm(:,:,1)+zwall_psi(:,:,2)*p_avm(:,:,2)) * & + & ustar2_surf(:,:)**rmm * zkar(:,:)**rnn * (zhsro(:,:) + gdept_n(:,:,1))**(rnn-1.) + zflxs(:,:) = zdep(:,:) * zflxs(:,:) + psi (:,:,2) = psi(:,:,2) + zflxs(:,:) / e3w_n(:,:,2) + ! + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_n(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 + ! + CASE ( 1 ) ! Neumman boundary condition + ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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_n(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_n(ji,jj,ibotm1) + END DO + END DO + ! + END SELECT + + ! Matrix inversion + ! ---------------- + ! + DO jk = 2, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! Third recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + eps(ji,jj,jk) = psi(ji,jj,jk) + END DO + END DO + END DO + ! + CASE( 2 ) ! k-w + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! Note that this set boundary conditions on hmxl_n at the same time + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! 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) + ! Galperin criterium (NOTE : Not required if the proper value of C3 in stable cases is calculated) + zrn2 = MAX( rn2(ji,jj,jk), rsmall ) + IF( ln_length_lim ) 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 + + ! + ! 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + ! 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 + + zstm(:,:,1) = zstm(:,:,2) + + ! default value, in case jpk > mbkt(ji,jj)+1. Not needed but avoid a bug when looking for undefined values (-fpe0) + zstm(:,:,jpk) = 0. + DO jj = 2, jpjm1 ! update bottom with good values + DO ji = fs_2, fs_jpim1 ! vector opt. + zstm(ji,jj,mbkt(ji,jj)+1) = zstm(ji,jj,mbkt(ji,jj)) + END DO + END DO + + zstt(:,:, 1) = wmask(:,:, 1) ! default value not needed but avoid a bug when looking for undefined values (-fpe0) + zstt(:,:,jpk) = wmask(:,:,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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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(:,:,1) = 0._wp + ! + IF(ln_ctl) THEN + CALL prt_ctl( tab3d_1=en , clinfo1=' gls - e: ', tab3d_2=p_avt, clinfo2=' t: ', kdim=jpk) + CALL prt_ctl( tab3d_1=p_avm, clinfo1=' gls - m: ', kdim=jpk ) + 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, & + & rn_crban, rn_charn, rn_frac_hs, & + & nn_bc_surf, nn_bc_bot, nn_z0_met, nn_z0_ice, & + & nn_stab_func, nn_clos + !!---------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namzdf_gls in reference namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme + READ ( numnam_ref, namzdf_gls, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_gls in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namzdf_gls in configuration namelist : Vertical eddy diffivity and viscosity using gls turbulent closure scheme + 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,*) ' Ice-ocean roughness (used if nn_z0_ice/=0) rn_hsri = ', rn_hsri + WRITE(numout,*) + WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:' + WRITE(numout,*) ' top ocean cavity roughness (m) rn_z0(_top) = ', r_z0_top + WRITE(numout,*) ' Bottom seafloor roughness (m) rn_z0(_bot) = ', r_z0_bot + 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 = rdt * 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 * rdt * rc0**(rpp-2._wp*rmm) / rsc_psi + rsbc_psi2 = -0.5_wp * rdt * rc0**rpp * rnn * vkarmn**rnn / rsc_psi ! Neumann + NO Wave breaking + ! + rfact_tke = -0.5_wp / rsc_tke * rdt ! Cst used for the Diffusion term of tke + rfact_psi = -0.5_wp / rsc_psi * rdt ! 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) + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('en') + CALL iom_set_rstw_var_active('avt_k') + CALL iom_set_rstw_var_active('avm_k') + CALL iom_set_rstw_var_active('hmxl_n') + ENDIF + ! + 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_autoglo, 'en' , en , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'avt_k' , avt_k , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'avm_k' , avm_k , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'hmxl_n', hmxl_n, ldxios = lrxios ) + 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 ----' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k' , avt_k , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k' , avm_k , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'hmxl_n', hmxl_n, ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ! + ENDIF + ! + END SUBROUTINE gls_rst + + !!====================================================================== +END MODULE zdfgls + diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfiwm.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfiwm.F90 new file mode 100644 index 0000000..941060f --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfiwm.F90 @@ -0,0 +1,495 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 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 * + INTEGER :: nn_zpyc ! pycnocline-intensified mixing energy proportional to N (=1) or N^2 (=2) + 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), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ebot_iwm ! power available from high-mode wave breaking (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: epyc_iwm ! power available from low-mode, pycnocline-intensified wave breaking (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: ecri_iwm ! power available from low-mode, critical slope wave breaking (W/m2) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbot_iwm ! WKB decay scale for high-mode energy dissipation (m) + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:) :: hcri_iwm ! decay scale for low-mode critical slope dissipation (m) + + !! * Substitutions +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_iwm_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_iwm_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( ebot_iwm(jpi,jpj), epyc_iwm(jpi,jpj), ecri_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, 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( 100 cm2/s, f( Reb = zemx_iwm /( Nu * N^2 ) ) + !! 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 three components: + !! 1. Bottom-intensified low-mode dissipation at critical slopes + !! zemx_iwm(z) = ( ecri_iwm / rau0 ) * 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 map of available power, and H the ocean depth. + !! 2. Pycnocline-intensified low-mode dissipation + !! zemx_iwm(z) = ( epyc_iwm / rau0 ) * ( sqrt(rn2(z))^nn_zpyc ) + !! / SUM( sqrt(rn2(z))^nn_zpyc * e3w(z) ) + !! where epyc_iwm is a map of available power, and nn_zpyc + !! is the chosen stratification-dependence of the internal wave + !! energy dissipation. + !! 3. WKB-height dependent high mode dissipation + !! zemx_iwm(z) = ( ebot_iwm / rau0 ) * rn2(z) * EXP(-z_wkb(z)/hbot_iwm) + !! / SUM( rn2(z) * EXP(-z_wkb(z)/hbot_iwm) * e3w(z) ) + !! where hbot_iwm is the characteristic length scale of the WKB bottom + !! intensification, ebot_iwm is a map of available power, and z_wkb is the + !! WKB-stretched height above bottom defined as + !! z_wkb(z) = H * SUM( sqrt(rn2(z'>=z)) * e3w(z'>=z) ) + !! / SUM( sqrt(rn2(z')) * e3w(z') ) + !! + !! - update the model vertical eddy viscosity and diffusivity: + !! avt = avt + av_wave + !! avm = avm + av_wave + !! + !! - if namelist parameter ln_tsdiff = T, account for differential mixing: + !! avs = avt + av_wave * diffusivity_ratio(Reb) + !! + !! ** Action : - avt, avs, avm, increased by tide internal wave-driven mixing + !! + !! References : de Lavergne et al. 2015, JPO; 2016, in prep. + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! ocean time step + 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) :: zztmp, ztmp1, ztmp2 ! scalar workspace + REAL(wp), DIMENSION(jpi,jpj) :: zfact ! Used for vertical structure + REAL(wp), DIMENSION(jpi,jpj) :: zhdep ! Ocean depth + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zwkb ! WKB-stretched height above bottom + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zweight ! Weight for high mode vertical distribution + REAL(wp), DIMENSION(jpi,jpj,jpk) :: znu_t ! Molecular kinematic viscosity (T grid) + REAL(wp), DIMENSION(jpi,jpj,jpk) :: znu_w ! Molecular kinematic viscosity (W grid) + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zReb ! Turbulence intensity parameter + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zemx_iwm ! local energy density available for mixing (W/kg) + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zav_ratio ! S/T diffusivity ratio (only for ln_tsdiff=T) + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zav_wave ! Internal wave-induced diffusivity + REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: z3d ! 3D workspace used for iom_put + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: z2d ! 2D - - - - + !!---------------------------------------------------------------------- + ! + ! !* Set to zero the 1st and last vertical levels of appropriate variables + zemx_iwm (:,:,1) = 0._wp ; zemx_iwm (:,:,jpk) = 0._wp + zav_ratio(:,:,1) = 0._wp ; zav_ratio(:,:,jpk) = 0._wp + zav_wave (:,:,1) = 0._wp ; zav_wave (:,:,jpk) = 0._wp + ! + ! ! ----------------------------- ! + ! ! Internal wave-driven mixing ! (compute zav_wave) + ! ! ----------------------------- ! + ! + ! !* Critical slope mixing: distribute energy over the time-varying ocean depth, + ! using an exponential decay from the seafloor. + DO jj = 1, jpj ! part independent of the level + DO ji = 1, jpi + zhdep(ji,jj) = gdepw_0(ji,jj,mbkt(ji,jj)+1) ! depth of the ocean + zfact(ji,jj) = rau0 * ( 1._wp - EXP( -zhdep(ji,jj) / hcri_iwm(ji,jj) ) ) + IF( zfact(ji,jj) /= 0._wp ) zfact(ji,jj) = ecri_iwm(ji,jj) / zfact(ji,jj) + END DO + END DO +!!gm gde3w ==>>> check for ssh taken into account.... seem OK gde3w_n=gdept_n - sshn + DO jk = 2, jpkm1 ! complete with the level-dependent part + DO jj = 1, jpj + DO ji = 1, jpi + IF ( zfact(ji,jj) == 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization + zemx_iwm(ji,jj,jk) = 0._wp + ELSE + zemx_iwm(ji,jj,jk) = zfact(ji,jj) * ( EXP( ( gde3w_n(ji,jj,jk ) - zhdep(ji,jj) ) / hcri_iwm(ji,jj) ) & + & - EXP( ( gde3w_n(ji,jj,jk-1) - zhdep(ji,jj) ) / hcri_iwm(ji,jj) ) ) & + & / ( gde3w_n(ji,jj,jk) - gde3w_n(ji,jj,jk-1) ) + ENDIF + END DO + END DO +!!gm delta(gde3w_n) = e3t_n !! Please verify the grid-point position w versus t-point +!!gm it seems to me that only 1/hcri_iwm is used ==> compute it one for all + + END DO + + ! !* Pycnocline-intensified mixing: distribute energy over the time-varying + ! !* ocean depth as proportional to sqrt(rn2)^nn_zpyc + ! ! (NB: N2 is masked, so no use of wmask here) + SELECT CASE ( nn_zpyc ) + ! + CASE ( 1 ) ! Dissipation scales as N (recommended) + ! + zfact(:,:) = 0._wp + DO jk = 2, jpkm1 ! part independent of the level + zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) + END DO + ! + DO jj = 1, jpj + DO ji = 1, jpi + IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rau0 * zfact(ji,jj) ) + END DO + END DO + ! + DO jk = 2, jpkm1 ! complete with the level-dependent part + zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) + END DO + ! + CASE ( 2 ) ! Dissipation scales as N^2 + ! + zfact(:,:) = 0._wp + DO jk = 2, jpkm1 ! part independent of the level + zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) + END DO + ! + DO jj= 1, jpj + DO ji = 1, jpi + IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = epyc_iwm(ji,jj) / ( rau0 * zfact(ji,jj) ) + END DO + END DO + ! + DO jk = 2, jpkm1 ! complete with the level-dependent part + zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zfact(:,:) * MAX( 0._wp, rn2(:,:,jk) ) * wmask(:,:,jk) + END DO + ! + END SELECT + + ! !* WKB-height dependent mixing: distribute energy over the time-varying + ! !* ocean depth as proportional to rn2 * exp(-z_wkb/rn_hbot) + ! + zwkb (:,:,:) = 0._wp + zfact(:,:) = 0._wp + DO jk = 2, jpkm1 + zfact(:,:) = zfact(:,:) + e3w_n(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) * wmask(:,:,jk) + zwkb(:,:,jk) = zfact(:,:) + END DO +!!gm even better: +! DO jk = 2, jpkm1 +! zwkb(:,:) = zwkb(:,:) + e3w_n(:,:,jk) * SQRT( MAX( 0._wp, rn2(:,:,jk) ) ) +! END DO +! zfact(:,:) = zwkb(:,:,jpkm1) +!!gm or just use zwkb(k=jpk-1) instead of zfact... +!!gm + ! + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF( zfact(ji,jj) /= 0 ) zwkb(ji,jj,jk) = zhdep(ji,jj) * ( zfact(ji,jj) - zwkb(ji,jj,jk) ) & + & * wmask(ji,jj,jk) / zfact(ji,jj) + END DO + END DO + END DO + zwkb(:,:,1) = zhdep(:,:) * wmask(:,:,1) + ! + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + IF ( rn2(ji,jj,jk) <= 0._wp .OR. wmask(ji,jj,jk) == 0._wp ) THEN ! optimization + zweight(ji,jj,jk) = 0._wp + ELSE + zweight(ji,jj,jk) = rn2(ji,jj,jk) * hbot_iwm(ji,jj) & + & * ( EXP( -zwkb(ji,jj,jk) / hbot_iwm(ji,jj) ) - EXP( -zwkb(ji,jj,jk-1) / hbot_iwm(ji,jj) ) ) + ENDIF + END DO + END DO + END DO + ! + zfact(:,:) = 0._wp + DO jk = 2, jpkm1 ! part independent of the level + zfact(:,:) = zfact(:,:) + zweight(:,:,jk) + END DO + ! + DO jj = 1, jpj + DO ji = 1, jpi + IF( zfact(ji,jj) /= 0 ) zfact(ji,jj) = ebot_iwm(ji,jj) / ( rau0 * zfact(ji,jj) ) + END DO + END DO + ! + DO jk = 2, jpkm1 ! complete with the level-dependent part + zemx_iwm(:,:,jk) = zemx_iwm(:,:,jk) + zweight(:,:,jk) * zfact(:,:) * wmask(:,:,jk) & + & / ( gde3w_n(:,:,jk) - gde3w_n(:,:,jk-1) ) +!!gm use of e3t_n just above? + END DO + ! +!!gm this is to be replaced by just a constant value znu=1.e-6 m2/s + ! Calculate molecular kinematic viscosity + znu_t(:,:,:) = 1.e-4_wp * ( 17.91_wp - 0.53810_wp * tsn(:,:,:,jp_tem) + 0.00694_wp * tsn(:,:,:,jp_tem) * tsn(:,:,:,jp_tem) & + & + 0.02305_wp * tsn(:,:,:,jp_sal) ) * tmask(:,:,:) * r1_rau0 + DO jk = 2, jpkm1 + znu_w(:,:,jk) = 0.5_wp * ( znu_t(:,:,jk-1) + znu_t(:,:,jk) ) * wmask(:,:,jk) + END DO +!!gm end + ! + ! Calculate turbulence intensity parameter Reb + DO jk = 2, jpkm1 + zReb(:,:,jk) = zemx_iwm(:,:,jk) / MAX( 1.e-20_wp, znu_w(:,:,jk) * rn2(:,:,jk) ) + END DO + ! + ! Define internal wave-induced diffusivity + DO jk = 2, jpkm1 + zav_wave(:,:,jk) = znu_w(:,:,jk) * zReb(:,:,jk) * r1_6 ! This corresponds to a constant mixing efficiency of 1/6 + END DO + ! + IF( ln_mevar ) THEN ! Variable mixing efficiency case : modify zav_wave in the + DO jk = 2, jpkm1 ! energetic (Reb > 480) and buoyancy-controlled (Reb <10.224 ) regimes + DO jj = 1, jpj + DO ji = 1, jpi + IF( zReb(ji,jj,jk) > 480.00_wp ) THEN + zav_wave(ji,jj,jk) = 3.6515_wp * znu_w(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) + ELSEIF( zReb(ji,jj,jk) < 10.224_wp ) THEN + zav_wave(ji,jj,jk) = 0.052125_wp * znu_w(ji,jj,jk) * zReb(ji,jj,jk) * SQRT( zReb(ji,jj,jk) ) + ENDIF + END DO + END DO + END DO + ENDIF + ! + DO jk = 2, jpkm1 ! Bound diffusivity by molecular value and 100 cm2/s + zav_wave(:,:,jk) = MIN( MAX( 1.4e-7_wp, zav_wave(:,:,jk) ), 1.e-2_wp ) * wmask(:,:,jk) + END DO + ! + IF( kt == nit000 ) THEN !* Control print at first time-step: diagnose the energy consumed by zav_wave + zztmp = 0._wp +!!gm used of glosum 3D.... + DO jk = 2, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zztmp = zztmp + e3w_n(ji,jj,jk) * 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 + CALL mpp_sum( 'zdfiwm', zztmp ) + zztmp = rau0 * zztmp ! Global integral of rauo * 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 + + ! ! ----------------------- ! + ! ! Update mixing coefs ! + ! ! ----------------------- ! + ! + IF( ln_tsdiff ) THEN !* Option for differential mixing of salinity and temperature + ztmp1 = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10( 1.e-20_wp ) - 0.60_wp ) ) + DO jk = 2, jpkm1 ! Calculate S/T diffusivity ratio as a function of Reb + DO jj = 1, jpj + DO ji = 1, jpi + ztmp2 = zReb(ji,jj,jk) * 5._wp * r1_6 + IF ( ztmp2 > 1.e-20_wp .AND. wmask(ji,jj,jk) == 1._wp ) THEN + zav_ratio(ji,jj,jk) = 0.505_wp + 0.495_wp * TANH( 0.92_wp * ( LOG10(ztmp2) - 0.60_wp ) ) + ELSE + zav_ratio(ji,jj,jk) = ztmp1 * wmask(ji,jj,jk) + ENDIF + END DO + END DO + END DO + CALL iom_put( "av_ratio", zav_ratio ) + DO jk = 2, jpkm1 !* update momentum & tracer diffusivity with wave-driven mixing + p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk) * zav_ratio(:,:,jk) + p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk) + p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk) + END DO + ! + ELSE !* update momentum & tracer diffusivity with wave-driven mixing + DO jk = 2, jpkm1 + p_avs(:,:,jk) = p_avs(:,:,jk) + zav_wave(:,:,jk) + p_avt(:,:,jk) = p_avt(:,:,jk) + zav_wave(:,:,jk) + p_avm(:,:,jk) = p_avm(:,:,jk) + zav_wave(:,:,jk) + END DO + ENDIF + + ! !* output internal wave-driven mixing coefficient + CALL iom_put( "av_wave", zav_wave ) + !* output useful diagnostics: Kz*N^2 , +!!gm Kz*N2 should take into account the ratio avs/avt if it is used.... (see diaar5) + ! vertical integral of rau0 * Kz * N^2 , energy density (zemx_iwm) + IF( iom_use("bflx_iwm") .OR. iom_use("pcmap_iwm") ) THEN + ALLOCATE( z2d(jpi,jpj) , z3d(jpi,jpj,jpk) ) + z3d(:,:,:) = MAX( 0._wp, rn2(:,:,:) ) * zav_wave(:,:,:) + z2d(:,:) = 0._wp + DO jk = 2, jpkm1 + z2d(:,:) = z2d(:,:) + e3w_n(:,:,jk) * z3d(:,:,jk) * wmask(:,:,jk) + END DO + z2d(:,:) = rau0 * z2d(:,:) + CALL iom_put( "bflx_iwm", z3d ) + CALL iom_put( "pcmap_iwm", z2d ) + DEALLOCATE( z2d , z3d ) + ENDIF + CALL iom_put( "emix_iwm", zemx_iwm ) + + IF(ln_ctl) CALL prt_ctl(tab3d_1=zav_wave , clinfo1=' iwm - av_wave: ', tab3d_2=avt, clinfo2=' avt: ', kdim=jpk) + ! + END SUBROUTINE zdf_iwm + + + SUBROUTINE zdf_iwm_init + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_iwm_init *** + !! + !! ** Purpose : Initialization of the wave-driven vertical mixing, reading + !! of input power maps and decay length scales in netcdf files. + !! + !! ** Method : - Read the namzdf_iwm namelist and check the parameters + !! + !! - Read the input data in NetCDF files : + !! power available from high-mode wave breaking (mixing_power_bot.nc) + !! power available from pycnocline-intensified wave-breaking (mixing_power_pyc.nc) + !! power available from critical slope wave-breaking (mixing_power_cri.nc) + !! WKB decay scale for high-mode wave-breaking (decay_scale_bot.nc) + !! decay scale for critical slope wave-breaking (decay_scale_cri.nc) + !! + !! ** input : - Namlist namzdf_iwm + !! - NetCDF files : mixing_power_bot.nc, mixing_power_pyc.nc, mixing_power_cri.nc, + !! decay_scale_bot.nc decay_scale_cri.nc + !! + !! ** Action : - Increase by 1 the nstop flag is setting problem encounter + !! - Define ebot_iwm, epyc_iwm, ecri_iwm, hbot_iwm, hcri_iwm + !! + !! References : de Lavergne et al. JPO, 2015 ; de Lavergne PhD 2016 + !! de Lavergne et al. in prep., 2017 + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: inum ! local integer + INTEGER :: ios + REAL(wp) :: zbot, zpyc, zcri ! local scalars + !! + NAMELIST/namzdf_iwm/ nn_zpyc, ln_mevar, ln_tsdiff + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namzdf_iwm in reference namelist : Wave-driven mixing + READ ( numnam_ref, namzdf_iwm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_iwm in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namzdf_iwm in configuration namelist : Wave-driven mixing + 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,*) ' Pycnocline-intensified diss. scales as N (=1) or N^2 (=2) = ', nn_zpyc + 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 + + ! The new 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(:) = 1.4e-6_wp ! viscous molecular value + avtb(:) = 1.e-10_wp ! very small diffusive minimum (background avt is specified in zdf_iwm) + avtb_2d(:,:) = 1.e0_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' ) + ! + ! ! read necessary fields + CALL iom_open('mixing_power_bot',inum) ! energy flux for high-mode wave breaking [W/m2] + CALL iom_get (inum, jpdom_data, 'field', ebot_iwm, 1 ) + CALL iom_close(inum) + ! + CALL iom_open('mixing_power_pyc',inum) ! energy flux for pynocline-intensified wave breaking [W/m2] + CALL iom_get (inum, jpdom_data, 'field', epyc_iwm, 1 ) + CALL iom_close(inum) + ! + CALL iom_open('mixing_power_cri',inum) ! energy flux for critical slope wave breaking [W/m2] + CALL iom_get (inum, jpdom_data, 'field', ecri_iwm, 1 ) + CALL iom_close(inum) + ! + CALL iom_open('decay_scale_bot',inum) ! spatially variable decay scale for high-mode wave breaking [m] + CALL iom_get (inum, jpdom_data, 'field', hbot_iwm, 1 ) + CALL iom_close(inum) + ! + CALL iom_open('decay_scale_cri',inum) ! spatially variable decay scale for critical slope wave breaking [m] + CALL iom_get (inum, jpdom_data, 'field', hcri_iwm, 1 ) + CALL iom_close(inum) + + ebot_iwm(:,:) = ebot_iwm(:,:) * ssmask(:,:) + epyc_iwm(:,:) = epyc_iwm(:,:) * ssmask(:,:) + ecri_iwm(:,:) = ecri_iwm(:,:) * ssmask(:,:) + + zbot = glob_sum( 'zdfiwm', e1e2t(:,:) * ebot_iwm(:,:) ) + zpyc = glob_sum( 'zdfiwm', e1e2t(:,:) * epyc_iwm(:,:) ) + zcri = glob_sum( 'zdfiwm', e1e2t(:,:) * ecri_iwm(:,:) ) + IF(lwp) THEN + WRITE(numout,*) ' High-mode wave-breaking energy: ', zbot * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Pycnocline-intensifed wave-breaking energy: ', zpyc * 1.e-12_wp, 'TW' + WRITE(numout,*) ' Critical slope wave-breaking energy: ', zcri * 1.e-12_wp, 'TW' + ENDIF + ! + END SUBROUTINE zdf_iwm_init + + !!====================================================================== +END MODULE zdfiwm diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfmxl.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfmxl.F90 new file mode 100644 index 0000000..82b38dd --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfmxl.F90 @@ -0,0 +1,525 @@ +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 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 eosbn2 ! for zdf_mxl_zint + ! + 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 ! called by zdfphy.F90 + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld_tref !: mixed layer depth at t-points - temperature criterion [m] + INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: nmln !: number of level in the mixed layer (used by TOP) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmld !: mixing layer depth (turbocline) [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlp !: mixed layer depth (rho=rho0+zdcrit) [m] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hmlpt !: depth of the last T-point inside the mixed layer [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: hmld_zint !: vertically-interpolated mixed layer depth [m] + REAL(wp), PUBLIC, ALLOCATABLE, DIMENSION(:,:,:) :: htc_mld ! Heat content of hmld_zint + LOGICAL, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ll_found ! Is T_b to be found by interpolation ? + LOGICAL, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ll_belowml ! Flag points below mixed layer when ll_found=F + + 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 + + TYPE, PUBLIC :: MXL_ZINT !: Structure for MLD defs + INTEGER :: mld_type ! mixed layer type + REAL(wp) :: zref ! depth of initial T_ref + REAL(wp) :: dT_crit ! Critical temp diff + REAL(wp) :: iso_frac ! Fraction of rn_dT_crit + END TYPE MXL_ZINT + +!Used for 25h mean + LOGICAL, PRIVATE :: mld_25h_init = .TRUE. !Logical used to initalise 25h + !outputs. Necessary, because we need to + !initalise the mld_25h on the zeroth + !timestep (i.e in the nemogcm_init call) + LOGICAL, PRIVATE :: mld_25h_write = .FALSE. !Logical confirm 25h calculating/processing + INTEGER, SAVE :: i_cnt_25h ! Counter for 25 hour means + INTEGER, PRIVATE :: nn_mld_diag = 0 ! number of diagnostics + INTEGER, PRIVATE, PARAMETER :: MAX_DIAG = 5 ! maximum number of diagnostics + LOGICAL, PRIVATE, DIMENSION(MAX_DIAG) :: cmld_zint, cmld_mld + + REAL(wp),SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: hmld_zint_25h + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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), hmld_zint(jpi,jpj, MAX_DIAG), & + htc_mld(jpi,jpj,MAX_DIAG), ll_found(jpi,jpj), ll_belowml(jpi,jpj,jpk), STAT= zdf_mxl_alloc ) + ! + ALLOCATE(hmld_tref(jpi,jpj)) + ! + 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 ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdfmxl *** + !! + !! ** Purpose : Compute the turbocline depth and 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 + !! 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 : nmln, hmld, hmlp, hmlpt + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt ! ocean time-step index + ! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: iikn, iiki, ikt ! local integer + REAL(wp) :: zN2_c ! local scalar + INTEGER, DIMENSION(jpi,jpj) :: imld ! 2D workspace + !!---------------------------------------------------------------------- + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'zdf_mxl : mixed layer depth' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ! ! allocate zdfmxl arrays + IF( zdf_mxl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl : unable to allocate arrays' ) + ENDIF + ! + ! w-level of the mixing and mixed layers + nmln(:,:) = nlb10 ! Initialization to the number of w ocean point + hmlp(:,:) = 0._wp ! here hmlp used as a dummy variable, integrating vertically N^2 + zN2_c = grav * rho_c * r1_rau0 ! convert density criteria into N^2 criteria + DO jk = nlb10, jpkm1 + DO jj = 1, jpj ! Mixed layer level: w-level + DO ji = 1, jpi + ikt = mbkt(ji,jj) + hmlp(ji,jj) = hmlp(ji,jj) + MAX( rn2b(ji,jj,jk) , 0._wp ) * e3w_n(ji,jj,jk) + IF( hmlp(ji,jj) < zN2_c ) nmln(ji,jj) = MIN( jk , ikt ) + 1 ! Mixed layer level + END DO + END DO + END DO + ! + ! w-level of the turbocline and mixing layer (iom_use) + imld(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point + DO jk = jpkm1, nlb10, -1 ! from the bottom to nlb10 + DO jj = 1, jpj + DO ji = 1, jpi + 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 and mixed layers + DO jj = 1, jpj + DO ji = 1, jpi + iiki = imld(ji,jj) + iikn = nmln(ji,jj) + hmld (ji,jj) = gdepw_n(ji,jj,iiki ) * ssmask(ji,jj) ! Turbocline depth + hmlp (ji,jj) = gdepw_n(ji,jj,iikn ) * ssmask(ji,jj) ! Mixed layer depth + hmlpt(ji,jj) = gdept_n(ji,jj,iikn-1) * ssmask(ji,jj) ! depth of the last T-point inside the mixed layer + END DO + END DO + ! + IF( .NOT.l_offline ) THEN + IF( iom_use("mldr10_1") ) THEN + 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 + END IF + IF( iom_use("mldkz5") ) THEN + IF( ln_isfcav ) THEN ; CALL iom_put( "mldkz5" , hmld - risfdep ) ! turbocline thickness + ELSE ; CALL iom_put( "mldkz5" , hmld ) ! turbocline depth + END IF + ENDIF + ENDIF + ! + ! Vertically-interpolated mixed-layer depth diagnostic + CALL zdf_mxl_zint( kt ) + ! + IF(ln_ctl) CALL prt_ctl( tab2d_1=REAL(nmln,wp), clinfo1=' nmln : ', tab2d_2=hmlp, clinfo2=' hmlp : ' ) + ! + END SUBROUTINE zdf_mxl + + SUBROUTINE zdf_mxl_zint_mld( sf ) + !!---------------------------------------------------------------------------------- + !! *** ROUTINE zdf_mxl_zint_mld *** + ! + ! Calculate vertically-interpolated mixed layer depth diagnostic. + ! + ! This routine can calculate the mixed layer depth diagnostic suggested by + ! Kara et al, 2000, JGR, 105, 16803, but is more general and can calculate + ! vertically-interpolated mixed-layer depth diagnostics with other parameter + ! settings set in the namzdf_mldzint namelist. + ! + ! If mld_type=1 the mixed layer depth is calculated as the depth at which the + ! density has increased by an amount equivalent to a temperature difference of + ! 0.8C at the surface. + ! + ! For other values of mld_type the mixed layer is calculated as the depth at + ! which the temperature differs by 0.8C from the surface temperature. + ! + ! David Acreman, Daley Calvert + ! + !!----------------------------------------------------------------------------------- + + TYPE(MXL_ZINT), DIMENSION(MAX_DIAG), INTENT(in) :: sf + + ! Diagnostic criteria + INTEGER :: nn_mld_type ! mixed layer type + REAL(wp) :: rn_zref ! depth of initial T_ref + REAL(wp) :: rn_dT_crit ! Critical temp diff + REAL(wp) :: rn_iso_frac ! Fraction of rn_dT_crit used + + ! Local variables + REAL(wp), PARAMETER :: zepsilon = 1.e-30 ! local small value + INTEGER, DIMENSION(jpi,jpj) :: ikmt ! number of active tracer levels + INTEGER, DIMENSION(jpi,jpj) :: ik_ref ! index of reference level + INTEGER, DIMENSION(jpi,jpj) :: ik_iso ! index of last uniform temp level + REAL, DIMENSION(jpi,jpj,jpk) :: zT ! Temperature or density + REAL, DIMENSION(jpi,jpj) :: ppzdep ! depth for use in calculating d(rho) + REAL, DIMENSION(jpi,jpj) :: zT_ref ! reference temperature + REAL :: zT_b ! base temperature + REAL, DIMENSION(jpi,jpj,jpk) :: zdTdz ! gradient of zT + REAL, DIMENSION(jpi,jpj,jpk) :: zmoddT ! Absolute temperature difference + REAL :: zdz ! depth difference + REAL :: zdT ! temperature difference + REAL, DIMENSION(jpi,jpj) :: zdelta_T ! difference critereon + REAL, DIMENSION(jpi,jpj) :: zRHO1, zRHO2 ! Densities + INTEGER :: ji, jj, jk, jn ! loop counter + + !!------------------------------------------------------------------------------------- + ! + ! Unpack structure + DO jn=1, nn_mld_diag + IF( cmld_zint(jn) .OR. cmld_mld(jn) ) THEN + nn_mld_type = sf(jn)%mld_type + rn_zref = sf(jn)%zref + rn_dT_crit = sf(jn)%dT_crit + rn_iso_frac = sf(jn)%iso_frac + + ! Set the mixed layer depth criterion at each grid point + IF( nn_mld_type == 0 ) THEN + zdelta_T(:,:) = rn_dT_crit + zT(:,:,:) = rhop(:,:,:) + ELSE IF( nn_mld_type == 1 ) THEN + ppzdep(:,:)=0.0 + call eos ( tsn(:,:,1,:), ppzdep(:,:), zRHO1(:,:) ) +! Use zT temporarily as a copy of tsn with rn_dT_crit added to SST +! [assumes number of tracers less than number of vertical levels] + zT(:,:,1:jpts)=tsn(:,:,1,1:jpts) + zT(:,:,jp_tem)=zT(:,:,1)+rn_dT_crit + CALL eos( zT(:,:,1:jpts), ppzdep(:,:), zRHO2(:,:) ) + zdelta_T(:,:) = abs( zRHO1(:,:) - zRHO2(:,:) ) * rau0 + ! RHO from eos (2d version) doesn't calculate north or east halo: + CALL lbc_lnk( 'zdfmxl', zdelta_T, 'T', 1. ) + zT(:,:,:) = rhop(:,:,:) + ELSE + zdelta_T(:,:) = rn_dT_crit + zT(:,:,:) = tsn(:,:,:,jp_tem) + END IF + + ! Calculate the gradient of zT and absolute difference for use later + DO jk = 1 ,jpk-2 + zdTdz(:,:,jk) = ( zT(:,:,jk+1) - zT(:,:,jk) ) / e3w_n(:,:,jk+1) + zmoddT(:,:,jk) = abs( zT(:,:,jk+1) - zT(:,:,jk) ) + END DO + + ! Find density/temperature at the reference level (Kara et al use 10m). + ! ik_ref is the index of the box centre immediately above or at the reference level + ! Find rn_zref in the array of model level depths and find the ref + ! density/temperature by linear interpolation. + DO jk = jpkm1, 2, -1 + WHERE ( gdept_n(:,:,jk) > rn_zref ) + ik_ref(:,:) = jk - 1 + zT_ref(:,:) = zT(:,:,jk-1) + zdTdz(:,:,jk-1) * ( rn_zref - gdept_n(:,:,jk-1) ) + END WHERE + END DO + + ! If the first grid box centre is below the reference level then use the + ! top model level to get zT_ref + WHERE ( gdept_n(:,:,1) > rn_zref ) + zT_ref = zT(:,:,1) + ik_ref = 1 + END WHERE + + ! The number of active tracer levels is 1 less than the number of active w levels + ikmt(:,:) = mbkt(:,:) - 1 + + ! Initialize / reset + ll_found(:,:) = .false. + + IF ( rn_iso_frac - zepsilon > 0. ) THEN + ! Search for a uniform density/temperature region where adjacent levels + ! differ by less than rn_iso_frac * deltaT. + ! ik_iso is the index of the last level in the uniform layer + ! ll_found indicates whether the mixed layer depth can be found by interpolation + ik_iso(:,:) = ik_ref(:,:) + DO jj = 1, nlcj + DO ji = 1, nlci +!CDIR NOVECTOR + DO jk = ik_ref(ji,jj), ikmt(ji,jj)-1 + IF ( zmoddT(ji,jj,jk) > ( rn_iso_frac * zdelta_T(ji,jj) ) ) THEN + ik_iso(ji,jj) = jk + ll_found(ji,jj) = ( zmoddT(ji,jj,jk) > zdelta_T(ji,jj) ) + EXIT + END IF + END DO + END DO + END DO + + ! Use linear interpolation to find depth of mixed layer base where possible + hmld_zint(:,:,jn) = rn_zref + DO jj = 1, jpj + DO ji = 1, jpi + IF (ll_found(ji,jj) .and. tmask(ji,jj,1) == 1.0) THEN + zdz = abs( zdelta_T(ji,jj) / zdTdz(ji,jj,ik_iso(ji,jj)) ) + hmld_zint(ji,jj,jn) = gdept_n(ji,jj,ik_iso(ji,jj)) + zdz + END IF + END DO + END DO + END IF + + ! If ll_found = .false. then calculate MLD using difference of zdelta_T + ! from the reference density/temperature + +! Prevent this section from working on land points + WHERE ( tmask(:,:,1) /= 1.0 ) + ll_found = .true. + END WHERE + + DO jk=1, jpk + ll_belowml(:,:,jk) = abs( zT(:,:,jk) - zT_ref(:,:) ) >= zdelta_T(:,:) + END DO + +! Set default value where interpolation cannot be used (ll_found=false) + DO jj = 1, jpj + DO ji = 1, jpi + IF ( .not. ll_found(ji,jj) ) hmld_zint(ji,jj,jn) = gdept_n(ji,jj,ikmt(ji,jj)) + END DO + END DO + + DO jj = 1, jpj + DO ji = 1, jpi +!CDIR NOVECTOR + DO jk = ik_ref(ji,jj)+1, ikmt(ji,jj) + IF ( ll_found(ji,jj) ) EXIT + IF ( ll_belowml(ji,jj,jk) ) THEN + zT_b = zT_ref(ji,jj) + zdelta_T(ji,jj) * SIGN(1.0, zdTdz(ji,jj,jk-1) ) + zdT = zT_b - zT(ji,jj,jk-1) + zdz = zdT / zdTdz(ji,jj,jk-1) + hmld_zint(ji,jj,jn) = gdept_n(ji,jj,jk-1) + zdz + EXIT + END IF + END DO + END DO + END DO + + hmld_zint(:,:,jn) = hmld_zint(:,:,jn)*tmask(:,:,1) + END IF + END DO + ! + END SUBROUTINE zdf_mxl_zint_mld + + SUBROUTINE zdf_mxl_zint_htc( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mxl_zint_htc *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + + INTEGER, INTENT(in) :: kt ! ocean time-step index + + INTEGER :: ji, jj, jk, jn + INTEGER :: ikmax + REAL(wp) :: zc, zcoef + ! + INTEGER, ALLOCATABLE, DIMENSION(:,:) :: ilevel + REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: zthick_0, zthick + + !!---------------------------------------------------------------------- + + IF( .NOT. ALLOCATED(ilevel) ) THEN + ALLOCATE( ilevel(jpi,jpj), zthick_0(jpi,jpj), & + & zthick(jpi,jpj), STAT=ji ) + IF( lk_mpp ) CALL mpp_sum( 'zdfmxl', ji ) + IF( ji /= 0 ) CALL ctl_stop( 'STOP', 'zdf_mxl_zint_htc : unable to allocate arrays' ) + ENDIF + + DO jn=1, nn_mld_diag + IF( cmld_mld(jn) ) THEN + ! Find last whole model T level above the MLD + ilevel(:,:) = 0 + zthick_0(:,:) = 0._wp + + DO jk = 1, jpkm1 + DO jj = 1, jpj + DO ji = 1, jpi + zthick_0(ji,jj) = zthick_0(ji,jj) + e3t_n(ji,jj,jk) + IF( zthick_0(ji,jj) < hmld_zint(ji,jj,jn) ) ilevel(ji,jj) = jk + END DO + END DO + WRITE(numout,*) 'zthick_0(jk =',jk,') =',zthick_0(2,2) + WRITE(numout,*) 'gdepw_n(jk+1 =',jk+1,') =',gdepw_n(2,2,jk+1) + END DO + + ! Surface boundary condition + IF( ln_linssh ) THEN ; zthick(:,:) = sshn(:,:) ; htc_mld(:,:,jn) = tsn(:,:,1,jp_tem) * sshn(:,:) * tmask(:,:,1) + ELSE ; zthick(:,:) = 0._wp ; htc_mld(:,:,jn) = 0._wp + ENDIF + + ! Deepest whole T level above the MLD + ikmax = MIN( MAXVAL( ilevel(:,:) ), jpkm1 ) + + ! Integration down to last whole model T level + DO jk = 1, ikmax + DO jj = 1, jpj + DO ji = 1, jpi + zc = e3t_n(ji,jj,jk) * REAL( MIN( MAX( 0, ilevel(ji,jj) - jk + 1 ) , 1 ) ) ! 0 below ilevel + zthick(ji,jj) = zthick(ji,jj) + zc + htc_mld(ji,jj,jn) = htc_mld(ji,jj,jn) + zc * tsn(ji,jj,jk,jp_tem) * tmask(ji,jj,jk) + END DO + END DO + END DO + + ! Subsequent partial T level + zthick(:,:) = hmld_zint(:,:,jn) - zthick(:,:) ! remaining thickness to reach MLD + + DO jj = 1, jpj + DO ji = 1, jpi + htc_mld(ji,jj,jn) = htc_mld(ji,jj,jn) + tsn(ji,jj,ilevel(ji,jj)+1,jp_tem) & + & * MIN( e3t_n(ji,jj,ilevel(ji,jj)+1), zthick(ji,jj) ) * tmask(ji,jj,ilevel(ji,jj)+1) + END DO + END DO + + WRITE(numout,*) 'htc_mld(after) =',htc_mld(2,2,jn) + + ! Convert to heat content + zcoef = rau0 * rcp + htc_mld(:,:,jn) = zcoef * htc_mld(:,:,jn) + END IF + END DO + + END SUBROUTINE zdf_mxl_zint_htc + + SUBROUTINE zdf_mxl_zint( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE zdf_mxl_zint *** + !! + !! ** Purpose : + !! + !! ** Method : + !!---------------------------------------------------------------------- + + INTEGER, INTENT(in) :: kt ! ocean time-step index + + INTEGER :: ios + INTEGER :: jn + + CHARACTER(len=1) :: cmld + + TYPE(MXL_ZINT) :: sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5 + TYPE(MXL_ZINT), SAVE, DIMENSION(MAX_DIAG) :: mld_diags + + NAMELIST/namzdf_mldzint/ nn_mld_diag, sn_mld1, sn_mld2, sn_mld3, sn_mld4, sn_mld5 + + !!---------------------------------------------------------------------- + + IF( kt == nit000 ) THEN + REWIND( numnam_ref ) ! Namelist namzdf_mldzint in reference namelist + READ ( numnam_ref, namzdf_mldzint, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_mldzint in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namzdf_mldzint in configuration namelist + READ ( numnam_cfg, namzdf_mldzint, IOSTAT = ios, ERR = 902 ) +902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_mldzint in configuration namelist' ) + IF(lwm) WRITE ( numond, namzdf_mldzint ) + + WRITE(cmld,'(I1)') MAX_DIAG + IF( nn_mld_diag > MAX_DIAG ) CALL ctl_stop( 'STOP', 'zdf_mxl_ini: Specify no more than ', 'cmld', ' MLD definitions' ) + + mld_diags(1) = sn_mld1 + mld_diags(2) = sn_mld2 + mld_diags(3) = sn_mld3 + mld_diags(4) = sn_mld4 + mld_diags(5) = sn_mld5 + + cmld_zint=.false. + cmld_mld=.false. + IF( nn_mld_diag > 0 ) THEN + IF( lwp ) THEN + WRITE(numout,*) '=============== Vertically-interpolated mixed layer ================' + WRITE(numout,*) '(Diagnostic number, nn_mld_type, rn_zref, rn_dT_crit, rn_iso_frac)' + END IF + + DO jn = 1, nn_mld_diag + ! Check if the diagnostics is being written to the output + WRITE(cmld,'(I1)') jn + IF( iom_use( "mldzint_"//cmld ) ) cmld_zint(jn)=.true. + IF( iom_use( "mldhtc_"//cmld ) ) cmld_mld(jn) =.true. + + IF( lwp ) THEN + WRITE(numout,*) 'MLD criterion',jn,':' + WRITE(numout,*) ' nn_mld_type =', mld_diags(jn)%mld_type + WRITE(numout,*) ' rn_zref =' , mld_diags(jn)%zref + WRITE(numout,*) ' rn_dT_crit =' , mld_diags(jn)%dT_crit + WRITE(numout,*) ' rn_iso_frac =', mld_diags(jn)%iso_frac + END IF + END DO + WRITE(numout,*) '====================================================================' + ENDIF + ENDIF + + IF( nn_mld_diag > 0 ) THEN + CALL zdf_mxl_zint_mld( mld_diags ) + CALL zdf_mxl_zint_htc( kt ) + + DO jn = 1, nn_mld_diag + WRITE(cmld,'(I1)') jn + IF( cmld_zint(jn) ) THEN + CALL iom_put( "mldzint_"//cmld, hmld_zint(:,:,jn) ) + ENDIF + + IF( cmld_mld(jn) ) THEN + CALL iom_put( "mldhtc_"//cmld , htc_mld(:,:,jn) ) + ENDIF + END DO + ENDIF + + END SUBROUTINE zdf_mxl_zint + + !!====================================================================== +END MODULE zdfmxl diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfosm.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfosm.F90 new file mode 100644 index 0000000..f310832 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfosm.F90 @@ -0,0 +1,1733 @@ +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) Bouyancy flux due to entrainment changed to include contribution from shear turbulence (for testing commented out). + !! 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) + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 'ln_zdfosm' OSMOSIS scheme + !!---------------------------------------------------------------------- + !! zdf_osm : update momentum and tracer Kz from osm scheme + !! zdf_osm_init : initialization, namelist read, and parameters control + !! 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 + !!---------------------------------------------------------------------- + USE oce ! ocean dynamics and active tracers + ! uses wn 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 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 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' + + 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/<ws>o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ghams !: non-local salinity flux (gamma/<ws>o) + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: etmean !: averaging operator for avt + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbl !: boundary layer depth + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: hbli !: intial boundary layer depth for stable blayer + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: dstokes !: penetration depth of the Stokes drift. + + ! !!** 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_osm_hbl0 = 10._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 + LOGICAL :: ln_dia_osm ! Use namelist rn_osm_la + + + LOGICAL :: ln_kpprimix = .true. ! Shear instability mixing + REAL(wp) :: rn_riinfty = 0.7 ! local Richardson Number limit for shear instability + REAL(wp) :: rn_difri = 0.005 ! maximum shear mixing at Rig = 0 (m2/s) + LOGICAL :: ln_convmix = .true. ! Convective instability mixing + REAL(wp) :: rn_difconv = 1._wp ! diffusivity when unstable below BL (m2/s) + + ! !!! ** General constants ** + REAL(wp) :: epsln = 1.0e-20_wp ! a small positive number + REAL(wp) :: pthird = 1._wp/3._wp ! 1/3 + REAL(wp) :: p2third = 2._wp/3._wp ! 2/3 + + INTEGER :: idebug = 236 + INTEGER :: jdebug = 228 + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION zdf_osm_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION zdf_osm_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( ghamu(jpi,jpj,jpk), ghamv(jpi,jpj,jpk), ghamt(jpi,jpj,jpk), ghams(jpi,jpj,jpk), & + & hbl(jpi,jpj) , hbli(jpi,jpj) , dstokes(jpi, jpj) , & + & etmean(jpi,jpj,jpk), STAT= zdf_osm_alloc ) + IF( zdf_osm_alloc /= 0 ) CALL ctl_warn('zdf_osm_alloc: failed to allocate zdf_osm arrays') + CALL mpp_sum ( 'zdfosm', zdf_osm_alloc ) + END FUNCTION zdf_osm_alloc + + + SUBROUTINE zdf_osm( kt, 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 + REAL(wp), DIMENSION(:,:,:), INTENT(inout) :: p_avm, p_avt ! momentum and tracer Kz (w-points) + !! + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ikbot, jkmax, jkm1, jkp2 ! + + REAL(wp) :: ztx, zty, zflageos, zstabl, zbuofdep,zucube ! + REAL(wp) :: zbeta, zthermal ! + REAL(wp) :: zehat, zeta, zhrib, zsig, zscale, zwst, zws, zwm ! Velocity scales + REAL(wp) :: zwsun, zwmun, zcons, zconm, zwcons, zwconm ! + REAL(wp) :: zsr, zbw, ze, zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zcomp , zrhd,zrhdr,zbvzed ! In situ density + INTEGER :: jm ! dummy loop indices + REAL(wp) :: zr1, zr2, zr3, zr4, zrhop ! Compression terms + REAL(wp) :: zflag, zrn2, zdep21, zdep32, zdep43 + REAL(wp) :: zesh2, zri, zfri ! Interior richardson mixing + REAL(wp) :: zdelta, zdelta2, zdzup, zdzdn, zdzh, zvath, zgat1, zdat1, zkm1m, zkm1t + REAL(wp) :: zt,zs,zu,zv,zrh ! variables used in constructing averages +! Scales + REAL(wp), DIMENSION(jpi,jpj) :: zrad0 ! Surface solar temperature flux (deg m/s) + REAL(wp), DIMENSION(jpi,jpj) :: zradh ! Radiative flux at bl base (Buoyancy units) + REAL(wp), DIMENSION(jpi,jpj) :: zradav ! Radiative flux, bl average (Buoyancy Units) + REAL(wp), DIMENSION(jpi,jpj) :: zustar ! friction velocity + REAL(wp), DIMENSION(jpi,jpj) :: zwstrl ! Langmuir velocity scale + REAL(wp), DIMENSION(jpi,jpj) :: zvstr ! Velocity scale that ends to zustar for large Langmuir number. + REAL(wp), DIMENSION(jpi,jpj) :: zwstrc ! Convective velocity scale + REAL(wp), DIMENSION(jpi,jpj) :: zuw0 ! Surface u-momentum flux + REAL(wp), DIMENSION(jpi,jpj) :: zvw0 ! Surface v-momentum flux + REAL(wp), DIMENSION(jpi,jpj) :: zwth0 ! Surface heat flux (Kinematic) + REAL(wp), DIMENSION(jpi,jpj) :: zws0 ! Surface freshwater flux + REAL(wp), DIMENSION(jpi,jpj) :: zwb0 ! Surface buoyancy flux + REAL(wp), DIMENSION(jpi,jpj) :: zwthav ! Heat flux - bl average + REAL(wp), DIMENSION(jpi,jpj) :: zwsav ! freshwater flux - bl average + REAL(wp), DIMENSION(jpi,jpj) :: zwbav ! Buoyancy flux - bl average + REAL(wp), DIMENSION(jpi,jpj) :: zwb_ent ! Buoyancy entrainment flux + REAL(wp), DIMENSION(jpi,jpj) :: zustke ! Surface Stokes drift + REAL(wp), DIMENSION(jpi,jpj) :: zla ! Trubulent Langmuir number + REAL(wp), DIMENSION(jpi,jpj) :: zcos_wind ! Cos angle of surface stress + REAL(wp), DIMENSION(jpi,jpj) :: zsin_wind ! Sin angle of surface stress + REAL(wp), DIMENSION(jpi,jpj) :: zhol ! Stability parameter for boundary layer + LOGICAL, DIMENSION(:,:), ALLOCATABLE :: lconv ! unstable/stable bl + + ! mixed-layer variables + + INTEGER, DIMENSION(jpi,jpj) :: ibld ! level of boundary layer base + INTEGER, DIMENSION(jpi,jpj) :: imld ! level of mixed-layer depth (pycnocline top) + + REAL(wp) :: ztgrad,zsgrad,zbgrad ! Temporary variables used to calculate pycnocline gradients + REAL(wp) :: zugrad,zvgrad ! temporary variables for calculating pycnocline shear + + REAL(wp), DIMENSION(jpi,jpj) :: zhbl ! bl depth - grid + REAL(wp), DIMENSION(jpi,jpj) :: zhml ! ml depth - grid + REAL(wp), DIMENSION(jpi,jpj) :: zdh ! pycnocline depth - grid + REAL(wp), DIMENSION(jpi,jpj) :: zdhdt ! BL depth tendency + REAL(wp), DIMENSION(jpi,jpj) :: zt_bl,zs_bl,zu_bl,zv_bl,zrh_bl ! averages over the depth of the blayer + REAL(wp), DIMENSION(jpi,jpj) :: zt_ml,zs_ml,zu_ml,zv_ml,zrh_ml ! averages over the depth of the mixed layer + REAL(wp), DIMENSION(jpi,jpj) :: zdt_bl,zds_bl,zdu_bl,zdv_bl,zdrh_bl,zdb_bl ! difference between blayer average and parameter at base of blayer + REAL(wp), DIMENSION(jpi,jpj) :: zdt_ml,zds_ml,zdu_ml,zdv_ml,zdrh_ml,zdb_ml ! difference between mixed layer average and parameter at base of blayer + REAL(wp), DIMENSION(jpi,jpj) :: zwth_ent,zws_ent ! heat and salinity fluxes at the top of the pycnocline + REAL(wp), DIMENSION(jpi,jpj) :: zuw_bse,zvw_bse ! momentum fluxes at the top of the pycnocline + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdtdz_pyc ! parametrized gradient of temperature in pycnocline + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdsdz_pyc ! parametrised gradient of salinity in pycnocline + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdbdz_pyc ! parametrised gradient of buoyancy in the pycnocline + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdudz_pyc ! u-shear across the pycnocline + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdvdz_pyc ! v-shear across the pycnocline + + ! Flux-gradient relationship variables + + REAL(wp) :: zl_c,zl_l,zl_eps ! Used to calculate turbulence length scale. + + REAL(wp), DIMENSION(jpi,jpj) :: zdifml_sc,zvisml_sc,zdifpyc_sc,zvispyc_sc,zbeta_d_sc,zbeta_v_sc ! Scales for eddy diffusivity/viscosity + REAL(wp), DIMENSION(jpi,jpj) :: zsc_wth_1,zsc_ws_1 ! Temporary scales used to calculate scalar non-gradient terms. + REAL(wp), DIMENSION(jpi,jpj) :: zsc_uw_1,zsc_uw_2,zsc_vw_1,zsc_vw_2 ! Temporary scales for non-gradient momentum flux terms. + REAL(wp), DIMENSION(jpi,jpj) :: zhbl_t ! holds boundary layer depth updated by full timestep + + ! For calculating Ri#-dependent mixing + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3du ! u-shear^2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: z3dv ! v-shear^2 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zrimix ! spatial form of ri#-induced diffusion + + ! Temporary variables + INTEGER :: inhml + INTEGER :: i_lconv_alloc + REAL(wp) :: znd,znd_d,zznd_ml,zznd_pyc,zznd_d ! temporary non-dimensional depths used in various routines + REAL(wp) :: ztemp, zari, zpert, zzdhdt, zdb ! temporary variables + REAL(wp) :: zthick, zz0, zz1 ! temporary variables + REAL(wp) :: zvel_max, zhbl_s ! temporary variables + REAL(wp) :: zfac ! temporary variable + REAL(wp) :: zus_x, zus_y ! temporary Stokes drift + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zviscos ! viscosity + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zdiffut ! t-diffusivity + + ! For debugging + INTEGER :: ikt + !!-------------------------------------------------------------------- + ! + ALLOCATE( lconv(jpi,jpj), STAT= i_lconv_alloc ) + IF( i_lconv_alloc /= 0 ) CALL ctl_warn('zdf_osm: failed to allocate lconv') + + ibld(:,:) = 0 ; imld(:,:) = 0 + zrad0(:,:) = 0._wp ; zradh(:,:) = 0._wp ; zradav(:,:) = 0._wp ; zustar(:,:) = 0._wp + zwstrl(:,:) = 0._wp ; zvstr(:,:) = 0._wp ; zwstrc(:,:) = 0._wp ; zuw0(:,:) = 0._wp + zvw0(:,:) = 0._wp ; zwth0(:,:) = 0._wp ; zws0(:,:) = 0._wp ; zwb0(:,:) = 0._wp + zwthav(:,:) = 0._wp ; zwsav(:,:) = 0._wp ; zwbav(:,:) = 0._wp ; zwb_ent(:,:) = 0._wp + zustke(:,:) = 0._wp ; zla(:,:) = 0._wp ; zcos_wind(:,:) = 0._wp ; zsin_wind(:,:) = 0._wp + zhol(:,:) = 0._wp + lconv(:,:) = .FALSE. + ! mixed layer + ! no initialization of zhbl or zhml (or zdh?) + zhbl(:,:) = 1._wp ; zhml(:,:) = 1._wp ; zdh(:,:) = 1._wp ; zdhdt(:,:) = 0._wp + zt_bl(:,:) = 0._wp ; zs_bl(:,:) = 0._wp ; zu_bl(:,:) = 0._wp ; zv_bl(:,:) = 0._wp + zrh_bl(:,:) = 0._wp ; zt_ml(:,:) = 0._wp ; zs_ml(:,:) = 0._wp ; zu_ml(:,:) = 0._wp + zv_ml(:,:) = 0._wp ; zrh_ml(:,:) = 0._wp ; zdt_bl(:,:) = 0._wp ; zds_bl(:,:) = 0._wp + zdu_bl(:,:) = 0._wp ; zdv_bl(:,:) = 0._wp ; zdrh_bl(:,:) = 0._wp ; zdb_bl(:,:) = 0._wp + zdt_ml(:,:) = 0._wp ; zds_ml(:,:) = 0._wp ; zdu_ml(:,:) = 0._wp ; zdv_ml(:,:) = 0._wp + zdrh_ml(:,:) = 0._wp ; zdb_ml(:,:) = 0._wp ; zwth_ent(:,:) = 0._wp ; zws_ent(:,:) = 0._wp + zuw_bse(:,:) = 0._wp ; zvw_bse(:,:) = 0._wp + ! + zdtdz_pyc(:,:,:) = 0._wp ; zdsdz_pyc(:,:,:) = 0._wp ; zdbdz_pyc(:,:,:) = 0._wp + zdudz_pyc(:,:,:) = 0._wp ; zdvdz_pyc(:,:,:) = 0._wp + ! + ! Flux-Gradient arrays. + zdifml_sc(:,:) = 0._wp ; zvisml_sc(:,:) = 0._wp ; zdifpyc_sc(:,:) = 0._wp + zvispyc_sc(:,:) = 0._wp ; zbeta_d_sc(:,:) = 0._wp ; zbeta_v_sc(:,:) = 0._wp + zsc_wth_1(:,:) = 0._wp ; zsc_ws_1(:,:) = 0._wp ; zsc_uw_1(:,:) = 0._wp + zsc_uw_2(:,:) = 0._wp ; zsc_vw_1(:,:) = 0._wp ; zsc_vw_2(:,:) = 0._wp + zhbl_t(:,:) = 0._wp ; zdhdt(:,:) = 0._wp + + zdiffut(:,:,:) = 0._wp ; zviscos(:,:,:) = 0._wp ; ghamt(:,:,:) = 0._wp + ghams(:,:,:) = 0._wp ; ghamu(:,:,:) = 0._wp ; ghamv(:,:,:) = 0._wp + + ! hbl = MAX(hbl,epsln) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Calculate boundary layer scales + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + ! Assume two-band radiation model for depth of OSBL + zz0 = rn_abs ! surface equi-partition in 2-bands + zz1 = 1. - rn_abs + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! Surface downward irradiance (so always +ve) + zrad0(ji,jj) = qsr(ji,jj) * r1_rau0_rcp + ! Downwards irradiance at base of boundary layer + zradh(ji,jj) = zrad0(ji,jj) * ( zz0 * EXP( -hbl(ji,jj)/rn_si0 ) + zz1 * EXP( -hbl(ji,jj)/rn_si1) ) + ! Downwards irradiance averaged over depth of the OSBL + zradav(ji,jj) = zrad0(ji,jj) * ( zz0 * ( 1.0 - EXP( -hbl(ji,jj)/rn_si0 ) )*rn_si0 & + & + zz1 * ( 1.0 - EXP( -hbl(ji,jj)/rn_si1 ) )*rn_si1 ) / hbl(ji,jj) + END DO + END DO + ! Turbulent surface fluxes and fluxes averaged over depth of the OSBL + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + ! Upwards surface Temperature flux for non-local term + zwth0(ji,jj) = - qns(ji,jj) * r1_rau0_rcp * tmask(ji,jj,1) + ! Upwards surface salinity flux for non-local term + zws0(ji,jj) = - ( ( emp(ji,jj)-rnf(ji,jj) ) * tsn(ji,jj,1,jp_sal) + sfx(ji,jj) ) * r1_rau0 * tmask(ji,jj,1) + ! Non radiative upwards surface buoyancy flux + zwb0(ji,jj) = grav * zthermal * zwth0(ji,jj) - grav * zbeta * zws0(ji,jj) + ! turbulent heat flux averaged over depth of OSBL + zwthav(ji,jj) = 0.5 * zwth0(ji,jj) - ( 0.5*( zrad0(ji,jj) + zradh(ji,jj) ) - zradav(ji,jj) ) + ! turbulent salinity flux averaged over depth of the OBSL + zwsav(ji,jj) = 0.5 * zws0(ji,jj) + ! turbulent buoyancy flux averaged over the depth of the OBSBL + zwbav(ji,jj) = grav * zthermal * zwthav(ji,jj) - grav * zbeta * zwsav(ji,jj) + ! Surface upward velocity fluxes + zuw0(ji,jj) = -utau(ji,jj) * r1_rau0 * tmask(ji,jj,1) + zvw0(ji,jj) = -vtau(ji,jj) * r1_rau0 * tmask(ji,jj,1) + ! Friction velocity (zustar), at T-point : LMD94 eq. 2 + zustar(ji,jj) = MAX( SQRT( SQRT( zuw0(ji,jj) * zuw0(ji,jj) + zvw0(ji,jj) * zvw0(ji,jj) ) ), 1.0e-8 ) + zcos_wind(ji,jj) = -zuw0(ji,jj) / ( zustar(ji,jj) * zustar(ji,jj) ) + zsin_wind(ji,jj) = -zvw0(ji,jj) / ( zustar(ji,jj) * zustar(ji,jj) ) + END DO + END DO + ! Calculate Stokes drift in direction of wind (zustke) and Stokes penetration depth (dstokes) + SELECT CASE (nn_osm_wave) + ! Assume constant La#=0.3 + CASE(0) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + zus_x = zcos_wind(ji,jj) * zustar(ji,jj) / 0.3**2 + zus_y = zsin_wind(ji,jj) * zustar(ji,jj) / 0.3**2 + zustke(ji,jj) = MAX ( SQRT( zus_x*zus_x + zus_y*zus_y), 1.0e-8 ) + ! dstokes(ji,jj) set to constant value rn_osm_dstokes from namelist in zdf_osm_init + END DO + END DO + ! Assume Pierson-Moskovitz wind-wave spectrum + CASE(1) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! Use wind speed wndm included in sbc_oce module + zustke(ji,jj) = MAX ( 0.016 * wndm(ji,jj), 1.0e-8 ) + dstokes(ji,jj) = 0.12 * wndm(ji,jj)**2 / grav + END DO + END DO + ! Use ECMWF wave fields as output from SBCWAVE + CASE(2) + zfac = 2.0_wp * rpi / 16.0_wp + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! The Langmur number from the ECMWF model appears to give La<0.3 for wind-driven seas. + ! The coefficient 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. + zustke(ji,jj) = MAX ( 1.0 * ( zcos_wind(ji,jj) * ut0sd(ji,jj ) + zsin_wind(ji,jj) * vt0sd(ji,jj) ), & + & zustar(ji,jj) / ( 0.45 * 0.45 ) ) + dstokes(ji,jj) = MAX(zfac * hsw(ji,jj)*hsw(ji,jj) / ( MAX(zustke(ji,jj)*wmp(ji,jj), 1.0e-7 ) ), 5.0e-1) !rn_osm_dstokes ! + END DO + END DO + END SELECT + + ! Langmuir velocity scale (zwstrl), La # (zla) + ! mixed scale (zvstr), convective velocity scale (zwstrc) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! Langmuir velocity scale (zwstrl), at T-point + zwstrl(ji,jj) = ( zustar(ji,jj) * zustar(ji,jj) * zustke(ji,jj) )**pthird + ! Modify zwstrl to allow for small and large values of dstokes/hbl. + ! Intended as a possible test. Doesn't affect LES results for entrainment, + ! but hasn't been shown to be correct as dstokes/h becomes large or small. + zwstrl(ji,jj) = zwstrl(ji,jj) * & + & (1.12 * ( 1.0 - ( 1.0 - EXP( -hbl(ji,jj) / dstokes(ji,jj) ) ) * dstokes(ji,jj) / hbl(ji,jj) ))**pthird * & + & ( 1.0 - EXP( -15.0 * dstokes(ji,jj) / hbl(ji,jj) )) + ! define La this way so effects of Stokes penetration depth on velocity scale are included + zla(ji,jj) = SQRT ( zustar(ji,jj) / zwstrl(ji,jj) )**3 + ! Velocity scale that tends to zustar for large Langmuir numbers + zvstr(ji,jj) = ( zwstrl(ji,jj)**3 + & + & ( 1.0 - EXP( -0.5 * zla(ji,jj)**2 ) ) * zustar(ji,jj) * zustar(ji,jj) * zustar(ji,jj) )**pthird + + ! limit maximum value of Langmuir number as approximate treatment for shear turbulence. + ! Note zustke and zwstrl are not amended. + IF ( zla(ji,jj) >= 0.45 ) zla(ji,jj) = 0.45 + ! + ! get convective velocity (zwstrc), stabilty scale (zhol) and logical conection flag lconv + IF ( zwbav(ji,jj) > 0.0) THEN + zwstrc(ji,jj) = ( 2.0 * zwbav(ji,jj) * 0.9 * hbl(ji,jj) )**pthird + zhol(ji,jj) = -0.9 * hbl(ji,jj) * 2.0 * zwbav(ji,jj) / (zvstr(ji,jj)**3 + epsln ) + lconv(ji,jj) = .TRUE. + ELSE + zhol(ji,jj) = -hbl(ji,jj) * 2.0 * zwbav(ji,jj)/ (zvstr(ji,jj)**3 + epsln ) + lconv(ji,jj) = .FALSE. + 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 2 levels deep. + hbl(:,:) = MAX(hbl(:,:), gdepw_n(:,:,3) ) + ibld(:,:) = 3 + DO jk = 4, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( hbl(ji,jj) >= gdepw_n(ji,jj,jk) ) THEN + ibld(ji,jj) = MIN(mbkt(ji,jj), jk) + ENDIF + END DO + END DO + END DO + + DO jj = 2, jpjm1 ! Vertical slab + DO ji = 2, jpim1 + zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + zt = 0._wp + zs = 0._wp + zu = 0._wp + zv = 0._wp + ! average over depth of boundary layer + zthick=0._wp + DO jm = 2, ibld(ji,jj) + zthick=zthick+e3t_n(ji,jj,jm) + zt = zt + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem) + zs = zs + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal) + zu = zu + e3t_n(ji,jj,jm) & + & * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) & + & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) + zv = zv + e3t_n(ji,jj,jm) & + & * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) & + & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) + END DO + zt_bl(ji,jj) = zt / zthick + zs_bl(ji,jj) = zs / zthick + zu_bl(ji,jj) = zu / zthick + zv_bl(ji,jj) = zv / zthick + zdt_bl(ji,jj) = zt_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem) + zds_bl(ji,jj) = zs_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal) + zdu_bl(ji,jj) = zu_bl(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) & + & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) + zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) & + & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) + zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj) + IF ( lconv(ji,jj) ) THEN ! Convective + zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) & + & + 0.135 * zla(ji,jj) * zwstrl(ji,jj)**3/hbl(ji,jj) ) + + zvel_max = - ( 1.0 + 1.0 * ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_rdt / hbl(ji,jj) ) & + & * zwb_ent(ji,jj) / ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird +! Entrainment including component due to shear turbulence. Modified Langmuir component, but gives same result for La=0.3 For testing uncomment. +! zwb_ent(ji,jj) = -( 2.0 * 0.2 * zwbav(ji,jj) & +! & + ( 0.15 * ( 1.0 - EXP( -0.5 * zla(ji,jj) ) ) + 0.03 / zla(ji,jj)**2 ) * zustar(ji,jj)**3/hbl(ji,jj) ) + +! zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_rdt / zhbl(ji,jj) ) * zwb_ent(ji,jj) / & +! & ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + zzdhdt = - zwb_ent(ji,jj) / ( zvel_max + MAX(zdb_bl(ji,jj),0.0) ) + ELSE ! Stable + zzdhdt = 0.32 * ( hbli(ji,jj) / hbl(ji,jj) -1.0 ) * zwstrl(ji,jj)**3 / hbli(ji,jj) & + & + ( ( 0.32 / 3.0 ) * exp ( -2.5 * ( hbli(ji,jj) / hbl(ji,jj) - 1.0 ) ) & + & - ( 0.32 / 3.0 - 0.135 * zla(ji,jj) ) * exp ( -12.5 * ( hbli(ji,jj) / hbl(ji,jj) ) ) ) & + & * zwstrl(ji,jj)**3 / hbli(ji,jj) + zzdhdt = zzdhdt + zwbav(ji,jj) + IF ( zzdhdt < 0._wp ) THEN + ! For long timsteps factor in brackets slows the rapid collapse of the OSBL + zpert = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_rdt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) + ELSE + zpert = 2.0 * ( 1.0 + 2.0 * zwstrl(ji,jj) * rn_rdt / hbl(ji,jj) ) * zwstrl(ji,jj)**2 / hbl(ji,jj) & + & + MAX( zdb_bl(ji,jj), 0.0 ) + ENDIF + zzdhdt = 2.0 * zzdhdt / zpert + ENDIF + zdhdt(ji,jj) = zzdhdt + END DO + END DO + + ! Calculate averages over depth of boundary layer + imld = ibld ! use imld to hold previous blayer index + ibld(:,:) = 3 + + zhbl_t(:,:) = hbl(:,:) + (zdhdt(:,:) - wn(ji,jj,ibld(ji,jj)))* rn_rdt ! certainly need wb here, so subtract it + zhbl_t(:,:) = MIN(zhbl_t(:,:), ht_n(:,:)) + zdhdt(:,:) = MIN(zdhdt(:,:), (zhbl_t(:,:) - hbl(:,:))/rn_rdt + wn(ji,jj,ibld(ji,jj))) ! adjustment to represent limiting by ocean bottom + + DO jk = 4, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( zhbl_t(ji,jj) >= gdepw_n(ji,jj,jk) ) THEN + ibld(ji,jj) = MIN(mbkt(ji,jj), jk) + ENDIF + END DO + END DO + END DO + +! +! Step through model levels taking account of buoyancy change to determine the effect on dhdt +! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( ibld(ji,jj) - imld(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 = imld(ji,jj) + zthermal = rab_n(ji,jj,1,jp_tem) + zbeta = rab_n(ji,jj,1,jp_sal) + IF ( lconv(ji,jj) ) THEN +!unstable + zvel_max = - ( 1.0 + 1.0 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * rn_rdt / hbl(ji,jj) ) & + & * zwb_ent(ji,jj) / ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + + DO jk = imld(ji,jj), ibld(ji,jj) + zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - tsn(ji,jj,jm,jp_tem) ) & + & - zbeta * ( zs_bl(ji,jj) - tsn(ji,jj,jm,jp_sal) ) ), 0.0 ) + zvel_max + + zhbl_s = zhbl_s + MIN( - zwb_ent(ji,jj) / zdb * rn_rdt / FLOAT(ibld(ji,jj)-imld(ji,jj) ), e3w_n(ji,jj,jk) ) + zhbl_s = MIN(zhbl_s, ht_n(ji,jj)) + + IF ( zhbl_s >= gdepw_n(ji,jj,jm+1) ) jm = jm + 1 + END DO + hbl(ji,jj) = zhbl_s + ibld(ji,jj) = jm + hbli(ji,jj) = hbl(ji,jj) + ELSE +! stable + DO jk = imld(ji,jj), ibld(ji,jj) + zdb = MAX( grav * ( zthermal * ( zt_bl(ji,jj) - tsn(ji,jj,jm,jp_tem) ) & + & - zbeta * ( zs_bl(ji,jj) - tsn(ji,jj,jm,jp_sal) ) ), 0.0 ) & + & + 2.0 * zwstrl(ji,jj)**2 / zhbl_s + + zhbl_s = zhbl_s + ( & + & 0.32 * ( hbli(ji,jj) / zhbl_s -1.0 ) & + & * zwstrl(ji,jj)**3 / hbli(ji,jj) & + & + ( ( 0.32 / 3.0 ) * EXP( - 2.5 * ( hbli(ji,jj) / zhbl_s -1.0 ) ) & + & - ( 0.32 / 3.0 - 0.0485 ) * EXP( - 12.5 * ( hbli(ji,jj) / zhbl_s ) ) ) & + & * zwstrl(ji,jj)**3 / hbli(ji,jj) ) / zdb * e3w_n(ji,jj,jk) / zdhdt(ji,jj) ! ALMG to investigate whether need to include wn here + + zhbl_s = MIN(zhbl_s, ht_n(ji,jj)) + IF ( zhbl_s >= gdepw_n(ji,jj,jm) ) jm = jm + 1 + END DO + hbl(ji,jj) = MAX(zhbl_s, gdepw_n(ji,jj,3) ) + ibld(ji,jj) = MAX(jm, 3 ) + IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj) + ENDIF ! IF ( lconv ) + ELSE +! change zero or one model level. + hbl(ji,jj) = zhbl_t(ji,jj) + IF ( lconv(ji,jj) ) THEN + hbli(ji,jj) = hbl(ji,jj) + ELSE + hbl(ji,jj) = MAX(hbl(ji,jj), gdepw_n(ji,jj,3) ) + IF ( hbl(ji,jj) > hbli(ji,jj) ) hbli(ji,jj) = hbl(ji,jj) + ENDIF + ENDIF + zhbl(ji,jj) = gdepw_n(ji,jj,ibld(ji,jj)) + END DO + END DO + dstokes(:,:) = MIN ( dstokes(:,:), hbl(:,:)/3. ) ! Limit delta for shallow boundary layers for calculating flux-gradient terms. + +! Recalculate averages over boundary layer after depth updated + ! Consider later combining this into the loop above and looking for columns + ! where the index for base of the boundary layer have changed + DO jj = 2, jpjm1 ! Vertical slab + DO ji = 2, jpim1 + zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + zt = 0._wp + zs = 0._wp + zu = 0._wp + zv = 0._wp + ! average over depth of boundary layer + zthick=0._wp + DO jm = 2, ibld(ji,jj) + zthick=zthick+e3t_n(ji,jj,jm) + zt = zt + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem) + zs = zs + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal) + zu = zu + e3t_n(ji,jj,jm) & + & * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) & + & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) + zv = zv + e3t_n(ji,jj,jm) & + & * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) & + & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) + END DO + zt_bl(ji,jj) = zt / zthick + zs_bl(ji,jj) = zs / zthick + zu_bl(ji,jj) = zu / zthick + zv_bl(ji,jj) = zv / zthick + zdt_bl(ji,jj) = zt_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem) + zds_bl(ji,jj) = zs_bl(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal) + zdu_bl(ji,jj) = zu_bl(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) & + & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) + zdv_bl(ji,jj) = zv_bl(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) & + & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) + zdb_bl(ji,jj) = grav * zthermal * zdt_bl(ji,jj) - grav * zbeta * zds_bl(ji,jj) + zhbl(ji,jj) = gdepw_n(ji,jj,ibld(ji,jj)) + IF ( lconv(ji,jj) ) THEN + IF ( zdb_bl(ji,jj) > 0._wp )THEN + IF ( ( zwstrc(ji,jj) / zvstr(ji,jj) )**3 <= 0.5 ) THEN ! near neutral stability + zari = 4.5 * ( zvstr(ji,jj)**2 ) & + & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 + ELSE ! unstable + zari = 4.5 * ( zwstrc(ji,jj)**2 ) & + & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 + ENDIF + IF ( zari > 0.2 ) THEN ! This test checks for weakly stratified pycnocline + zari = 0.2 + zwb_ent(ji,jj) = 0._wp + ENDIF + inhml = MAX( INT( zari * zhbl(ji,jj) / e3t_n(ji,jj,ibld(ji,jj)) ) , 1 ) + imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) + zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj)) + zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) + ELSE ! IF (zdb_bl) + imld(ji,jj) = ibld(ji,jj) - 1 + zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj)) + zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) + ENDIF + ELSE ! IF (lconv) + IF ( zdhdt(ji,jj) >= 0.0 ) THEN ! probably shouldn't include wm here + ! boundary layer deepening + IF ( zdb_bl(ji,jj) > 0._wp ) THEN + ! pycnocline thickness set by stratification - use same relationship as for neutral conditions. + zari = MIN( 4.5 * ( zvstr(ji,jj)**2 ) & + & / ( zdb_bl(ji,jj) * zhbl(ji,jj) ) + 0.01 , 0.2 ) + inhml = MAX( INT( zari * zhbl(ji,jj) / e3t_n(ji,jj,ibld(ji,jj)) ) , 1 ) + imld(ji,jj) = MAX( ibld(ji,jj) - inhml, 1) + zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj)) + zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) + ELSE + imld(ji,jj) = ibld(ji,jj) - 1 + zhml(ji,jj) = gdepw_n(ji,jj,imld(ji,jj)) + zdh(ji,jj) = zhbl(ji,jj) - zhml(ji,jj) + ENDIF ! IF (zdb_bl > 0.0) + ELSE ! IF(dhdt >= 0) + ! boundary layer collapsing. + imld(ji,jj) = ibld(ji,jj) + zhml(ji,jj) = zhbl(ji,jj) + zdh(ji,jj) = 0._wp + ENDIF ! IF (dhdt >= 0) + ENDIF ! IF (lconv) + END DO + END DO + + ! Average over the depth of the mixed layer in the convective boundary layer + ! Also calculate entrainment fluxes for temperature and salinity + DO jj = 2, jpjm1 ! Vertical slab + DO ji = 2, jpim1 + zthermal = rab_n(ji,jj,1,jp_tem) !ideally use ibld not 1?? + zbeta = rab_n(ji,jj,1,jp_sal) + IF ( lconv(ji,jj) ) THEN + zt = 0._wp + zs = 0._wp + zu = 0._wp + zv = 0._wp + ! average over depth of boundary layer + zthick=0._wp + DO jm = 2, imld(ji,jj) + zthick=zthick+e3t_n(ji,jj,jm) + zt = zt + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem) + zs = zs + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal) + zu = zu + e3t_n(ji,jj,jm) & + & * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) & + & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) + zv = zv + e3t_n(ji,jj,jm) & + & * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) & + & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) + END DO + zt_ml(ji,jj) = zt / zthick + zs_ml(ji,jj) = zs / zthick + zu_ml(ji,jj) = zu / zthick + zv_ml(ji,jj) = zv / zthick + zdt_ml(ji,jj) = zt_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem) + zds_ml(ji,jj) = zs_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal) + zdu_ml(ji,jj) = zu_ml(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) & + & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) + zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) & + & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) + zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj) + ELSE + ! stable, if entraining calulate average below interface layer. + IF ( zdhdt(ji,jj) >= 0._wp ) THEN + zt = 0._wp + zs = 0._wp + zu = 0._wp + zv = 0._wp + ! average over depth of boundary layer + zthick=0._wp + DO jm = 2, imld(ji,jj) + zthick=zthick+e3t_n(ji,jj,jm) + zt = zt + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_tem) + zs = zs + e3t_n(ji,jj,jm) * tsn(ji,jj,jm,jp_sal) + zu = zu + e3t_n(ji,jj,jm) & + & * ( ub(ji,jj,jm) + ub(ji - 1,jj,jm) ) & + & / MAX( 1. , umask(ji,jj,jm) + umask(ji - 1,jj,jm) ) + zv = zv + e3t_n(ji,jj,jm) & + & * ( vb(ji,jj,jm) + vb(ji,jj - 1,jm) ) & + & / MAX( 1. , vmask(ji,jj,jm) + vmask(ji,jj - 1,jm) ) + END DO + zt_ml(ji,jj) = zt / zthick + zs_ml(ji,jj) = zs / zthick + zu_ml(ji,jj) = zu / zthick + zv_ml(ji,jj) = zv / zthick + zdt_ml(ji,jj) = zt_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_tem) + zds_ml(ji,jj) = zs_ml(ji,jj) - tsn(ji,jj,ibld(ji,jj),jp_sal) + zdu_ml(ji,jj) = zu_ml(ji,jj) - ( ub(ji,jj,ibld(ji,jj)) + ub(ji-1,jj,ibld(ji,jj) ) ) & + & / MAX(1. , umask(ji,jj,ibld(ji,jj) ) + umask(ji-1,jj,ibld(ji,jj) ) ) + zdv_ml(ji,jj) = zv_ml(ji,jj) - ( vb(ji,jj,ibld(ji,jj)) + vb(ji,jj-1,ibld(ji,jj) ) ) & + & / MAX(1. , vmask(ji,jj,ibld(ji,jj) ) + vmask(ji,jj-1,ibld(ji,jj) ) ) + zdb_ml(ji,jj) = grav * zthermal * zdt_ml(ji,jj) - grav * zbeta * zds_ml(ji,jj) + ENDIF + ENDIF + END DO + END DO + ! + ! rotate mean currents and changes onto wind align co-ordinates + ! + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ztemp = zu_ml(ji,jj) + zu_ml(ji,jj) = zu_ml(ji,jj) * zcos_wind(ji,jj) + zv_ml(ji,jj) * zsin_wind(ji,jj) + zv_ml(ji,jj) = zv_ml(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj) + ztemp = zdu_ml(ji,jj) + zdu_ml(ji,jj) = zdu_ml(ji,jj) * zcos_wind(ji,jj) + zdv_ml(ji,jj) * zsin_wind(ji,jj) + zdv_ml(ji,jj) = zdv_ml(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj) + ! + ztemp = zu_bl(ji,jj) + zu_bl = zu_bl(ji,jj) * zcos_wind(ji,jj) + zv_bl(ji,jj) * zsin_wind(ji,jj) + zv_bl(ji,jj) = zv_bl(ji,jj) * zcos_wind(ji,jj) - ztemp * zsin_wind(ji,jj) + ztemp = zdu_bl(ji,jj) + zdu_bl(ji,jj) = zdu_bl(ji,jj) * zcos_wind(ji,jj) + zdv_bl(ji,jj) * zsin_wind(ji,jj) + zdv_bl(ji,jj) = zdv_bl(ji,jj) * zsin_wind(ji,jj) - ztemp * zsin_wind(ji,jj) + END DO + END DO + + zuw_bse = 0._wp + zvw_bse = 0._wp + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + + IF ( lconv(ji,jj) ) THEN + IF ( zdb_bl(ji,jj) > 0._wp ) THEN + zwth_ent(ji,jj) = zwb_ent(ji,jj) * zdt_ml(ji,jj) / (zdb_ml(ji,jj) + epsln) + zws_ent(ji,jj) = zwb_ent(ji,jj) * zds_ml(ji,jj) / (zdb_ml(ji,jj) + epsln) + ENDIF + ELSE + zwth_ent(ji,jj) = -2.0 * zwthav(ji,jj) * ( (1.0 - 0.8) - ( 1.0 - 0.8)**(3.0/2.0) ) + zws_ent(ji,jj) = -2.0 * zwsav(ji,jj) * ( (1.0 - 0.8 ) - ( 1.0 - 0.8 )**(3.0/2.0) ) + ENDIF + END DO + END DO + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Pycnocline gradients for scalars and velocity + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! + IF ( lconv (ji,jj) ) THEN + ! Unstable conditions + IF( zdb_bl(ji,jj) > 0._wp ) THEN + ! calculate pycnocline profiles, no need if zdb_bl <= 0. since profile is zero and arrays have been initialized to zero + ztgrad = ( zdt_ml(ji,jj) / zdh(ji,jj) ) + zsgrad = ( zds_ml(ji,jj) / zdh(ji,jj) ) + zbgrad = ( zdb_ml(ji,jj) / zdh(ji,jj) ) + DO jk = 2 , ibld(ji,jj) + znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj) + zdtdz_pyc(ji,jj,jk) = ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + zdbdz_pyc(ji,jj,jk) = zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + zdsdz_pyc(ji,jj,jk) = zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + END DO + ENDIF + ELSE + ! stable conditions + ! if pycnocline profile only defined when depth steady of increasing. + IF ( zdhdt(ji,jj) >= 0.0 ) THEN ! Depth increasing, or steady. + IF ( zdb_bl(ji,jj) > 0._wp ) THEN + IF ( zhol(ji,jj) >= 0.5 ) THEN ! Very stable - 'thick' pycnocline + ztgrad = zdt_bl(ji,jj) / zhbl(ji,jj) + zsgrad = zds_bl(ji,jj) / zhbl(ji,jj) + zbgrad = zdb_bl(ji,jj) / zhbl(ji,jj) + DO jk = 2, ibld(ji,jj) + znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj) + zdtdz_pyc(ji,jj,jk) = ztgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) + zdbdz_pyc(ji,jj,jk) = zbgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) + zdsdz_pyc(ji,jj,jk) = zsgrad * EXP( -15.0 * ( znd - 0.9 )**2 ) + END DO + ELSE ! Slightly stable - 'thin' pycnoline - needed when stable layer begins to form. + ztgrad = zdt_bl(ji,jj) / zdh(ji,jj) + zsgrad = zds_bl(ji,jj) / zdh(ji,jj) + zbgrad = zdb_bl(ji,jj) / zdh(ji,jj) + DO jk = 2, ibld(ji,jj) + znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj) + zdtdz_pyc(ji,jj,jk) = ztgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + zdbdz_pyc(ji,jj,jk) = zbgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + zdsdz_pyc(ji,jj,jk) = zsgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + END DO + ENDIF ! IF (zhol >=0.5) + ENDIF ! IF (zdb_bl> 0.) + ENDIF ! IF (zdhdt >= 0) zdhdt < 0 not considered since pycnocline profile is zero, profile arrays are intialized to zero + ENDIF ! IF (lconv) + ! + END DO + END DO +! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ! + IF ( lconv (ji,jj) ) THEN + ! Unstable conditions + zugrad = ( zdu_ml(ji,jj) / zdh(ji,jj) ) + 0.275 * zustar(ji,jj)*zustar(ji,jj) / & + & (( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zhml(ji,jj) ) / zla(ji,jj)**(8.0/3.0) + zvgrad = ( zdv_ml(ji,jj) / zdh(ji,jj) ) + 3.5 * ff_t(ji,jj) * zustke(ji,jj) / & + & ( zwstrl(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + DO jk = 2 , ibld(ji,jj)-1 + znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj) + zdudz_pyc(ji,jj,jk) = zugrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -1.75 * ( znd + 0.75 )**2 ) + END DO + ELSE + ! stable conditions + zugrad = 3.25 * zdu_bl(ji,jj) / zhbl(ji,jj) + zvgrad = 2.75 * zdv_bl(ji,jj) / zhbl(ji,jj) + DO jk = 2, ibld(ji,jj) + znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj) + IF ( znd < 1.0 ) THEN + zdudz_pyc(ji,jj,jk) = zugrad * EXP( -40.0 * ( znd - 1.0 )**2 ) + ELSE + zdudz_pyc(ji,jj,jk) = zugrad * EXP( -20.0 * ( znd - 1.0 )**2 ) + ENDIF + zdvdz_pyc(ji,jj,jk) = zvgrad * EXP( -20.0 * ( znd - 0.85 )**2 ) + END DO + ENDIF + ! + END DO + END DO + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Eddy viscosity/diffusivity and non-gradient terms in the flux-gradient relationship + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + ! WHERE ( lconv ) + ! zdifml_sc = zhml * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird + ! zvisml_sc = zdifml_sc + ! zdifpyc_sc = 0.165 * ( zwstrl**3 + zwstrc**3 )**pthird * ( zhbl - zhml ) + ! zvispyc_sc = 0.142 * ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * ( zhbl - zhml ) + ! zbeta_d_sc = 1.0 - (0.165 / 0.8 * ( zhbl - zhml ) / zhbl )**p2third + ! zbeta_v_sc = 1.0 - 2.0 * (0.142 /0.375) * (zhbl - zhml ) / zhml + ! ELSEWHERE + ! zdifml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 ) + ! zvisml_sc = zwstrl * zhbl * EXP ( -( zhol / 0.183_wp )**2 ) + ! ENDWHERE + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + zdifml_sc(ji,jj) = zhml(ji,jj) * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird + zvisml_sc(ji,jj) = zdifml_sc(ji,jj) + zdifpyc_sc(ji,jj) = 0.165 * ( zvstr(ji,jj)**3 + 0.5 *zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj) + zvispyc_sc(ji,jj) = 0.142 * ( zvstr(ji,jj)**3 + 0.5 * zwstrc(ji,jj)**3 )**pthird * zdh(ji,jj) + zbeta_d_sc(ji,jj) = 1.0 - (0.165 / 0.8 * zdh(ji,jj) / zhbl(ji,jj) )**p2third + zbeta_v_sc(ji,jj) = 1.0 - 2.0 * (0.142 /0.375) * zdh(ji,jj) / zhml(ji,jj) + ELSE + zdifml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ) + zvisml_sc(ji,jj) = zvstr(ji,jj) * zhbl(ji,jj) * EXP ( -( zhol(ji,jj) / 0.6_wp )**2 ) + END IF + END DO + END DO +! + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2, imld(ji,jj) ! mixed layer diffusivity + zznd_ml = gdepw_n(ji,jj,jk) / zhml(ji,jj) + ! + zdiffut(ji,jj,jk) = 0.8 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_d_sc(ji,jj) * zznd_ml )**1.5 + ! + zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * ( 1.0 - zbeta_v_sc(ji,jj) * zznd_ml ) & + & * ( 1.0 - 0.5 * zznd_ml**2 ) + END DO + ! pycnocline - if present linear profile + IF ( zdh(ji,jj) > 0._wp ) THEN + DO jk = imld(ji,jj)+1 , ibld(ji,jj) + zznd_pyc = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj) + ! + zdiffut(ji,jj,jk) = zdifpyc_sc(ji,jj) * ( 1.0 + zznd_pyc ) + ! + zviscos(ji,jj,jk) = zvispyc_sc(ji,jj) * ( 1.0 + zznd_pyc ) + END DO + ENDIF + ! Temporay fix to ensure zdiffut is +ve; won't be necessary with wn taken out + zdiffut(ji,jj,ibld(ji,jj)) = zdhdt(ji,jj)* e3t_n(ji,jj,ibld(ji,jj)) + ! could be taken out, take account of entrainment represents as a diffusivity + ! should remove w from here, represents entrainment + ELSE + ! stable conditions + DO jk = 2, ibld(ji,jj) + zznd_ml = gdepw_n(ji,jj,jk) / zhbl(ji,jj) + zdiffut(ji,jj,jk) = 0.75 * zdifml_sc(ji,jj) * zznd_ml * ( 1.0 - zznd_ml )**1.5 + zviscos(ji,jj,jk) = 0.375 * zvisml_sc(ji,jj) * zznd_ml * (1.0 - zznd_ml) * ( 1.0 - zznd_ml**2 ) + END DO + ENDIF ! end if ( lconv ) +! + END DO ! end of ji loop + END DO ! end of jj loop + + ! + ! calculate non-gradient components of the flux-gradient relationships + ! +! Stokes term in scalar flux, flux-gradient relationship + WHERE ( lconv ) + zsc_wth_1 = zwstrl**3 * zwth0 / ( zvstr**3 + 0.5 * zwstrc**3 + epsln) + ! + zsc_ws_1 = zwstrl**3 * zws0 / ( zvstr**3 + 0.5 * zwstrc**3 + epsln ) + ELSEWHERE + zsc_wth_1 = 2.0 * zwthav + ! + zsc_ws_1 = 2.0 * zwsav + ENDWHERE + + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2, imld(ji,jj) + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 1.35 * EXP ( -zznd_d ) * ( 1.0 - EXP ( -2.0 * zznd_d ) ) * zsc_wth_1(ji,jj) + ! + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 1.35 * EXP ( -zznd_d ) * ( 1.0 - EXP ( -2.0 * zznd_d ) ) * zsc_ws_1(ji,jj) + END DO ! end jk loop + ELSE ! else for if (lconv) + ! Stable conditions + DO jk = 2, ibld(ji,jj) + zznd_d=gdepw_n(ji,jj,jk) / dstokes(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 1.5 * EXP ( -0.9 * zznd_d ) & + & * ( 1.0 - EXP ( -4.0 * zznd_d ) ) * zsc_wth_1(ji,jj) + ! + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 1.5 * EXP ( -0.9 * zznd_d ) & + & * ( 1.0 - EXP ( -4.0 * zznd_d ) ) * zsc_ws_1(ji,jj) + END DO + ENDIF ! endif for check on lconv + + END DO ! end of ji loop + END DO ! end of jj loop + + +! Stokes term in flux-gradient relationship (note in zsc_uw_n don't use zvstr since term needs to go to zero as zwstrl goes to zero) + WHERE ( lconv ) + zsc_uw_1 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke /( 1.0 - 1.0 * 6.5 * zla**(8.0/3.0) ) + zsc_uw_2 = ( zwstrl**3 + 0.5 * zwstrc**3 )**pthird * zustke / ( zla**(8.0/3.0) + epsln ) + zsc_vw_1 = ff_t * zhml * zustke**3 * zla**(8.0/3.0) / ( ( zvstr**3 + 0.5 * zwstrc**3 )**(2.0/3.0) + epsln ) + ELSEWHERE + zsc_uw_1 = zustar**2 + zsc_vw_1 = ff_t * zhbl * zustke**3 * zla**(8.0/3.0) / (zvstr**2 + epsln) + ENDWHERE + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2, imld(ji,jj) + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + ( -0.05 * EXP ( -0.4 * zznd_d ) * zsc_uw_1(ji,jj) & + & + 0.00125 * EXP ( - zznd_d ) * zsc_uw_2(ji,jj) ) & + & * ( 1.0 - EXP ( -2.0 * zznd_d ) ) +! + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) - 0.65 * 0.15 * EXP ( - zznd_d ) & + & * ( 1.0 - EXP ( -2.0 * zznd_d ) ) * zsc_vw_1(ji,jj) + END DO ! end jk loop + ELSE +! Stable conditions + DO jk = 2, ibld(ji,jj) ! corrected to ibld + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) - 0.75 * 1.3 * EXP ( -0.5 * zznd_d ) & + & * ( 1.0 - EXP ( -4.0 * zznd_d ) ) * zsc_uw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + 0._wp + END DO ! end jk loop + ENDIF + END DO ! ji loop + END DO ! jj loo + +! Buoyancy term in flux-gradient relationship [note : includes ROI ratio (X0.3) and pressure (X0.5)] + + WHERE ( lconv ) + zsc_wth_1 = zwbav * zwth0 * ( 1.0 + EXP ( 0.2 * zhol ) ) / ( zvstr**3 + 0.5 * zwstrc**3 + epsln ) + zsc_ws_1 = zwbav * zws0 * ( 1.0 + EXP ( 0.2 * zhol ) ) / ( zvstr**3 + 0.5 * zwstrc**3 + epsln ) + ELSEWHERE + zsc_wth_1 = 0._wp + zsc_ws_1 = 0._wp + ENDWHERE + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF (lconv(ji,jj) ) THEN + DO jk = 2, imld(ji,jj) + zznd_ml = gdepw_n(ji,jj,jk) / zhml(ji,jj) + ! calculate turbulent length scale + zl_c = 0.9 * ( 1.0 - EXP ( - 7.0 * ( zznd_ml - zznd_ml**3 / 3.0 ) ) ) & + & * ( 1.0 - EXP ( -15.0 * ( 1.1 - zznd_ml ) ) ) + zl_l = 2.0 * ( 1.0 - EXP ( - 2.0 * ( zznd_ml - zznd_ml**3 / 3.0 ) ) ) & + & * ( 1.0 - EXP ( - 5.0 * ( 1.0 - zznd_ml ) ) ) * ( 1.0 + dstokes(ji,jj) / zhml (ji,jj) ) + zl_eps = zl_l + ( zl_c - zl_l ) / ( 1.0 + EXP ( 3.0 * LOG10 ( - zhol(ji,jj) ) ) ) ** (3.0/2.0) + ! non-gradient buoyancy terms + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * 0.5 * zsc_wth_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * 0.5 * zsc_ws_1(ji,jj) * zl_eps * zhml(ji,jj) / ( 0.15 + zznd_ml ) + END DO + ELSE + DO jk = 2, ibld(ji,jj) + 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 DO + ENDIF + END DO ! ji loop + END DO ! jj loop + + + WHERE ( lconv ) + zsc_uw_1 = -zwb0 * zustar**2 * zhml / ( zvstr**3 + 0.5 * zwstrc**3 + epsln ) + zsc_uw_2 = zwb0 * zustke * zhml / ( zvstr**3 + 0.5 * zwstrc**3 + epsln )**(2.0/3.0) + zsc_vw_1 = 0._wp + ELSEWHERE + zsc_uw_1 = 0._wp + zsc_vw_1 = 0._wp + ENDWHERE + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2 , imld(ji,jj) + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.3 * 0.5 * ( zsc_uw_1(ji,jj) + 0.125 * EXP( -0.5 * zznd_d ) & + & * ( 1.0 - EXP( -0.5 * zznd_d ) ) & + & * zsc_uw_2(ji,jj) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zsc_vw_1(ji,jj) + END DO ! jk loop + ELSE + ! stable conditions + DO jk = 2, ibld(ji,jj) + 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 DO + ENDIF + END DO ! ji loop + END DO ! jj loop + +! Transport term in flux-gradient relationship [note : includes ROI ratio (X0.3) ] + + WHERE ( lconv ) + zsc_wth_1 = zwth0 + zsc_ws_1 = zws0 + ELSEWHERE + zsc_wth_1 = 2.0 * zwthav + zsc_ws_1 = zws0 + ENDWHERE + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2, imld(ji,jj) + zznd_ml=gdepw_n(ji,jj,jk) / zhml(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * zsc_wth_1(ji,jj) & + & * ( -2.0 + 2.75 * ( ( 1.0 + 0.6 * zznd_ml**4 ) & + & - EXP( - 6.0 * zznd_ml ) ) ) & + & * ( 1.0 - EXP( - 15.0 * ( 1.0 - zznd_ml ) ) ) + ! + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * zsc_ws_1(ji,jj) & + & * ( -2.0 + 2.75 * ( ( 1.0 + 0.6 * zznd_ml**4 ) & + & - EXP( - 6.0 * zznd_ml ) ) ) & + & * ( 1.0 - EXP ( -15.0 * ( 1.0 - zznd_ml ) ) ) + END DO + ELSE + DO jk = 2, ibld(ji,jj) + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & + & 7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_wth_1(ji,jj) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + 0.3 * ( -4.06 * EXP( -2.0 * zznd_d ) * (1.0 - EXP( -4.0 * zznd_d ) ) + & + & 7.5 * EXP ( -10.0 * ( 0.95 - znd )**2 ) * ( 1.0 - znd ) ) * zsc_ws_1(ji,jj) + END DO + ENDIF + ENDDO ! ji loop + END DO ! jj loop + + + WHERE ( lconv ) + zsc_uw_1 = zustar**2 + zsc_vw_1 = ff_t * zustke * zhml + ELSEWHERE + zsc_uw_1 = zustar**2 + zsc_uw_2 = (2.25 - 3.0 * ( 1.0 - EXP( -1.25 * 2.0 ) ) ) * ( 1.0 - EXP( -4.0 * 2.0 ) ) * zsc_uw_1 + zsc_vw_1 = ff_t * zustke * zhbl + zsc_vw_2 = -0.11 * SIN( 3.14159 * ( 2.0 + 0.4 ) ) * EXP(-( 1.5 + 2.0 )**2 ) * zsc_vw_1 + ENDWHERE + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2, imld(ji,jj) + zznd_ml = gdepw_n(ji,jj,jk) / zhml(ji,jj) + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk)& + & + 0.3 * ( -2.0 + 2.5 * ( 1.0 + 0.1 * zznd_ml**4 ) - EXP ( -8.0 * zznd_ml ) ) * zsc_uw_1(ji,jj) + ! + ghamv(ji,jj,jk) = ghamv(ji,jj,jk)& + & + 0.3 * 0.1 * ( EXP( -zznd_d ) + EXP( -5.0 * ( 1.0 - zznd_ml ) ) ) * zsc_vw_1(ji,jj) + END DO + ELSE + DO jk = 2, ibld(ji,jj) + znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj) + zznd_d = gdepw_n(ji,jj,jk) / dstokes(ji,jj) + IF ( zznd_d <= 2.0 ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + 0.5 * 0.3 & + &* ( 2.25 - 3.0 * ( 1.0 - EXP( - 1.25 * zznd_d ) ) * ( 1.0 - EXP( -2.0 * zznd_d ) ) ) * zsc_uw_1(ji,jj) + ! + ELSE + ghamu(ji,jj,jk) = ghamu(ji,jj,jk)& + & + 0.5 * 0.3 * ( 1.0 - EXP( -5.0 * ( 1.0 - znd ) ) ) * zsc_uw_2(ji,jj) + ! + ENDIF + + ghamv(ji,jj,jk) = ghamv(ji,jj,jk)& + & + 0.3 * 0.15 * SIN( 3.14159 * ( 0.65 * zznd_d ) ) * EXP( -0.25 * zznd_d**2 ) * zsc_vw_1(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk)& + & + 0.3 * 0.15 * EXP( -5.0 * ( 1.0 - znd ) ) * ( 1.0 - EXP( -20.0 * ( 1.0 - znd ) ) ) * zsc_vw_2(ji,jj) + END DO + ENDIF + END DO + END DO +! +! Make surface forced velocity non-gradient terms go to zero at the base of the mixed layer. + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 2, ibld(ji,jj) + znd = ( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about + IF ( znd >= 0.0 ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0 - EXP( -30.0 * znd**2 ) ) + ELSE + ghamu(ji,jj,jk) = 0._wp + ghamv(ji,jj,jk) = 0._wp + ENDIF + END DO + ELSE + DO jk = 2, ibld(ji,jj) + znd = ( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zhml(ji,jj) !ALMG to think about + IF ( znd >= 0.0 ) THEN + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * ( 1.0 - EXP( -10.0 * znd**2 ) ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * ( 1.0 - EXP( -10.0 * znd**2 ) ) + ELSE + ghamu(ji,jj,jk) = 0._wp + ghamv(ji,jj,jk) = 0._wp + ENDIF + END DO + ENDIF + END DO + END DO + + ! pynocline contributions + ! Temporary fix to avoid instabilities when zdb_bl becomes very very small + zsc_uw_1 = 0._wp ! 50.0 * zla**(8.0/3.0) * zustar**2 * zhbl / ( zdb_bl + epsln ) + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + DO jk= 2, ibld(ji,jj) + znd = gdepw_n(ji,jj,jk) / zhbl(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zdiffut(ji,jj,jk) * zdtdz_pyc(ji,jj,jk) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + zdiffut(ji,jj,jk) * zdsdz_pyc(ji,jj,jk) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zviscos(ji,jj,jk) * zdudz_pyc(ji,jj,jk) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zsc_uw_1(ji,jj) * ( 1.0 - znd )**(7.0/4.0) * zdbdz_pyc(ji,jj,jk) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zviscos(ji,jj,jk) * zdvdz_pyc(ji,jj,jk) + END DO + END DO + END DO + +! Entrainment contribution. + + DO jj=2, jpjm1 + DO ji = 2, jpim1 + IF ( lconv(ji,jj) ) THEN + DO jk = 1, imld(ji,jj) - 1 + znd=gdepw_n(ji,jj,jk) / zhml(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * znd + ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * znd + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * znd + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * znd + END DO + DO jk = imld(ji,jj), ibld(ji,jj) + znd = -( gdepw_n(ji,jj,jk) - zhml(ji,jj) ) / zdh(ji,jj) + ghamt(ji,jj,jk) = ghamt(ji,jj,jk) + zwth_ent(ji,jj) * ( 1.0 + znd ) + ghams(ji,jj,jk) = ghams(ji,jj,jk) + zws_ent(ji,jj) * ( 1.0 + znd ) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) + zuw_bse(ji,jj) * ( 1.0 + znd ) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) + zvw_bse(ji,jj) * ( 1.0 + znd ) + END DO + ENDIF + ghamt(ji,jj,ibld(ji,jj)) = 0._wp + ghams(ji,jj,ibld(ji,jj)) = 0._wp + ghamu(ji,jj,ibld(ji,jj)) = 0._wp + ghamv(ji,jj,ibld(ji,jj)) = 0._wp + END DO ! ji loop + END DO ! jj loop + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! 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 + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + DO jk = 2, ibld(ji,jj) + ztemp = ghamu(ji,jj,jk) + ghamu(ji,jj,jk) = ghamu(ji,jj,jk) * zcos_wind(ji,jj) - ghamv(ji,jj,jk) * zsin_wind(ji,jj) + ghamv(ji,jj,jk) = ghamv(ji,jj,jk) * zcos_wind(ji,jj) + ztemp * zsin_wind(ji,jj) + END DO + END DO + END DO + + IF(ln_dia_osm) THEN + IF ( iom_use("zdtdz_pyc") ) CALL iom_put( "zdtdz_pyc", wmask*zdtdz_pyc ) + END IF + +! KPP-style Ri# mixing + IF( ln_kpprimix) THEN + DO jk = 2, jpkm1 !* Shear production at uw- and vw-points (energy conserving form) + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! vector opt. + z3du(ji,jj,jk) = 0.5 * ( un(ji,jj,jk-1) - un(ji ,jj,jk) ) & + & * ( ub(ji,jj,jk-1) - ub(ji ,jj,jk) ) * wumask(ji,jj,jk) & + & / ( e3uw_n(ji,jj,jk) * e3uw_b(ji,jj,jk) ) + z3dv(ji,jj,jk) = 0.5 * ( vn(ji,jj,jk-1) - vn(ji,jj ,jk) ) & + & * ( vb(ji,jj,jk-1) - vb(ji,jj ,jk) ) * wvmask(ji,jj,jk) & + & / ( e3vw_n(ji,jj,jk) * e3vw_b(ji,jj,jk) ) + END DO + END DO + END DO + ! + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + ! ! shear prod. at w-point weightened by mask + zesh2 = ( z3du(ji-1,jj,jk) + z3du(ji,jj,jk) ) / MAX( 1._wp , umask(ji-1,jj,jk) + umask(ji,jj,jk) ) & + & + ( z3dv(ji,jj-1,jk) + z3dv(ji,jj,jk) ) / MAX( 1._wp , vmask(ji,jj-1,jk) + vmask(ji,jj,jk) ) + ! ! local Richardson number + zri = MAX( rn2b(ji,jj,jk), 0._wp ) / MAX(zesh2, epsln) + zfri = MIN( zri / rn_riinfty , 1.0_wp ) + zfri = ( 1.0_wp - zfri * zfri ) + zrimix(ji,jj,jk) = zfri * zfri * zfri * wmask(ji, jj, jk) + END DO + END DO + END DO + + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + DO jk = ibld(ji,jj) + 1, jpkm1 + zdiffut(ji,jj,jk) = zrimix(ji,jj,jk)*rn_difri + zviscos(ji,jj,jk) = zrimix(ji,jj,jk)*rn_difri + 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 = 2, jpjm1 + DO ji = 2, jpim1 + DO jk = ibld(ji,jj) + 1, jpkm1 + IF( MIN( rn2(ji,jj,jk), rn2b(ji,jj,jk) ) <= -1.e-12 ) zdiffut(ji,jj,jk) = rn_difconv + END DO + END DO + END DO + END IF ! ln_convmix = .true. + + ! Lateral boundary conditions on zvicos (sign unchanged), needed to caclulate viscosities on u and v grids + CALL lbc_lnk( 'zdfosm', zviscos(:,:,:), 'W', 1. ) + + ! GN 25/8: need to change tmask --> wmask + + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + 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 + ! Lateral boundary conditions on ghamu and ghamv, currently on W-grid (sign unchanged), needed to caclulate gham[uv] on u and v grids + CALL lbc_lnk_multi( 'zdfosm', p_avt, 'W', 1. , p_avm, 'W', 1., & + & ghamu, 'W', 1. , ghamv, 'W', 1. ) + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ghamu(ji,jj,jk) = ( ghamu(ji,jj,jk) + ghamu(ji+1,jj,jk) ) & + & / MAX( 1., 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., 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 gham[ts], on W-grid (sign unchanged) + ! Lateral boundary conditions on final outputs for gham[uv], on [UV]-grid (sign unchanged) + CALL lbc_lnk_multi( 'zdfosm', ghamt, 'W', 1. , ghams, 'W', 1., & + & ghamu, 'U', 1. , ghamv, 'V', 1. ) + + 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) + IF ( iom_use("us_x") ) CALL iom_put( "us_x", tmask(:,:,1)*zustke*zcos_wind ) ! x surface Stokes drift + IF ( iom_use("us_y") ) CALL iom_put( "us_y", tmask(:,:,1)*zustke*zsin_wind ) ! y surface Stokes drift + IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rau0*tmask(:,:,1)*zustar**2*zustke ) + ! Stokes drift read in from sbcwave (=2). + CASE(2) + IF ( iom_use("us_x") ) CALL iom_put( "us_x", ut0sd ) ! x surface Stokes drift + IF ( iom_use("us_y") ) CALL iom_put( "us_y", vt0sd ) ! y surface Stokes drift + IF ( iom_use("wind_wave_abs_power") ) CALL iom_put( "wind_wave_abs_power", 1000.*rau0*tmask(:,:,1)*zustar**2* & + & SQRT(ut0sd**2 + vt0sd**2 ) ) + END SELECT + IF ( iom_use("ghamt") ) CALL iom_put( "ghamt", tmask*ghamt ) ! <Tw_NL> + IF ( iom_use("ghams") ) CALL iom_put( "ghams", tmask*ghams ) ! <Sw_NL> + IF ( iom_use("ghamu") ) CALL iom_put( "ghamu", umask*ghamu ) ! <uw_NL> + IF ( iom_use("ghamv") ) CALL iom_put( "ghamv", vmask*ghamv ) ! <vw_NL> + IF ( iom_use("zwth0") ) CALL iom_put( "zwth0", tmask(:,:,1)*zwth0 ) ! <Tw_0> + IF ( iom_use("zws0") ) CALL iom_put( "zws0", tmask(:,:,1)*zws0 ) ! <Sw_0> + IF ( iom_use("hbl") ) CALL iom_put( "hbl", tmask(:,:,1)*hbl ) ! boundary-layer depth + IF ( iom_use("hbli") ) CALL iom_put( "hbli", tmask(:,:,1)*hbli ) ! Initial boundary-layer depth + IF ( iom_use("dstokes") ) CALL iom_put( "dstokes", tmask(:,:,1)*dstokes ) ! Stokes drift penetration depth + IF ( iom_use("zustke") ) CALL iom_put( "zustke", tmask(:,:,1)*zustke ) ! Stokes drift magnitude at T-points + IF ( iom_use("zwstrc") ) CALL iom_put( "zwstrc", tmask(:,:,1)*zwstrc ) ! convective velocity scale + IF ( iom_use("zwstrl") ) CALL iom_put( "zwstrl", tmask(:,:,1)*zwstrl ) ! Langmuir velocity scale + IF ( iom_use("zustar") ) CALL iom_put( "zustar", tmask(:,:,1)*zustar ) ! friction velocity scale + IF ( iom_use("wind_power") ) CALL iom_put( "wind_power", 1000.*rau0*tmask(:,:,1)*zustar**3 ) ! BL depth internal to zdf_osm routine + IF ( iom_use("wind_wave_power") ) CALL iom_put( "wind_wave_power", 1000.*rau0*tmask(:,:,1)*zustar**2*zustke ) + IF ( iom_use("zhbl") ) CALL iom_put( "zhbl", tmask(:,:,1)*zhbl ) ! BL depth internal to zdf_osm routine + IF ( iom_use("zhml") ) CALL iom_put( "zhml", tmask(:,:,1)*zhml ) ! ML depth internal to zdf_osm routine + IF ( iom_use("zdh") ) CALL iom_put( "zdh", tmask(:,:,1)*zdh ) ! ML depth internal to zdf_osm routine + IF ( iom_use("zhol") ) CALL iom_put( "zhol", tmask(:,:,1)*zhol ) ! ML depth internal to zdf_osm routine + IF ( iom_use("zwthav") ) CALL iom_put( "zwthav", tmask(:,:,1)*zwthav ) ! ML depth internal to zdf_osm routine + IF ( iom_use("zwth_ent") ) CALL iom_put( "zwth_ent", tmask(:,:,1)*zwth_ent ) ! ML depth internal to zdf_osm routine + IF ( iom_use("zt_ml") ) CALL iom_put( "zt_ml", tmask(:,:,1)*zt_ml ) ! average T in ML + END IF + ! Lateral boundary conditions on p_avt (sign unchanged) + CALL lbc_lnk( 'zdfosm', p_avt(:,:,:), 'W', 1. ) + ! + END SUBROUTINE zdf_osm + + + SUBROUTINE zdf_osm_init + !!---------------------------------------------------------------------- + !! *** 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 : Namlist namosm + !!---------------------------------------------------------------------- + INTEGER :: ios ! local integer + INTEGER :: ji, jj, jk ! dummy loop indices + !! + NAMELIST/namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave & + & ,nn_osm_wave, ln_dia_osm, rn_osm_hbl0 & + & ,ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namzdf_osm in reference namelist : Osmosis ML model + READ ( numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_osm in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy + 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 tke mixing parameters' + WRITE(numout,*) ' Use namelist rn_osm_la ln_use_osm_la = ', ln_use_osm_la + WRITE(numout,*) ' Turbulent Langmuir number rn_osm_la = ', rn_osm_la + 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,*) ' Output osm diagnostics ln_dia_osm = ', ln_dia_osm + 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 + + ! ! allocate zdfosm arrays + IF( zdf_osm_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'zdf_osm_init : unable to allocate arrays' ) + + call osm_rst( nit000, 'READ' ) !* read or initialize hbl + + 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 ' + ENDIF + ENDIF + + + !set constants not in namelist + !----------------------------- + + IF(lwp) THEN + WRITE(numout,*) + ENDIF + + 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.e0 + + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + etmean(ji,jj,jk) = tmask(ji,jj,jk) & + & / MAX( 1., 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.e0 + + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 ! vector opt. + etmean(ji,jj,jk) = tmask(ji, jj,jk) & + & / MAX( 1., 2.* tmask(ji,jj,jk) & + & +.5 * ( 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. * ( 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. + ghams(:,:,:) = 0. + ghamu(:,:,:) = 0. + ghamv(:,:,:) = 0. + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('wn') + CALL iom_set_rstw_var_active('hbl') + CALL iom_set_rstw_var_active('hbli') + ENDIF + END SUBROUTINE zdf_osm_init + + + SUBROUTINE osm_rst( kt, 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 + CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag + + INTEGER :: id1, id2 ! 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(:,:), ALLOCATABLE :: 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_autoglo, 'wn', wn, ldxios = lrxios ) + WRITE(numout,*) ' ===>>>> : wn read from restart file' + ELSE + wn(:,:,:) = 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, 'hbli' , ldstop = .FALSE. ) + IF( id1 > 0 .AND. id2 > 0) THEN ! 'hbl' exists; read and return + CALL iom_get( numror, jpdom_autoglo, 'hbl' , hbl , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'hbli', hbli, ldxios = lrxios ) + WRITE(numout,*) ' ===>>>> : hbl & hbli read from restart file' + RETURN + ELSE ! 'hbl' & 'hbli' 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 !* Write hbli into the restart file, then return + IF(lwp) WRITE(numout,*) '---- osm-rst ----' + CALL iom_rstput( kt, nitrst, numrow, 'wn' , wn , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'hbl' , hbl , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'hbli' , hbli, ldxios = lwxios ) + RETURN + END IF + + !!----------------------------------------------------------------------------- + ! Getting hbl, no restart file with hbl, so calculate from surface stratification + !!----------------------------------------------------------------------------- + IF( lwp ) WRITE(numout,*) ' ===>>>> : calculating hbl computed from stratification' + ALLOCATE( imld_rst(jpi,jpj) ) + ! w-level of the mixing and mixed layers + CALL eos_rab( tsn, rab_n ) + CALL bn2(tsn, rab_n, rn2) + imld_rst(:,:) = nlb10 ! Initialization to the number of w ocean point + hbl(:,:) = 0._wp ! here hbl used as a dummy variable, integrating vertically N^2 + zN2_c = grav * rho_c * r1_rau0 ! convert density criteria into N^2 criteria + ! + hbl(:,:) = 0._wp ! here hbl used as a dummy variable, integrating vertically N^2 + DO jk = 1, jpkm1 + DO jj = 1, jpj ! Mixed layer level: w-level + DO ji = 1, jpi + ikt = mbkt(ji,jj) + hbl(ji,jj) = hbl(ji,jj) + MAX( rn2(ji,jj,jk) , 0._wp ) * e3w_n(ji,jj,jk) + 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 = 1, jpj + DO ji = 1, jpi + iiki = imld_rst(ji,jj) + hbl (ji,jj) = gdepw_n(ji,jj,iiki ) * ssmask(ji,jj) ! Turbocline depth + END DO + END DO + hbl = MAX(hbl,epsln) + hbli(:,:) = hbl(:,:) + DEALLOCATE( imld_rst ) + WRITE(numout,*) ' ===>>>> : hbl computed from stratification' + END SUBROUTINE osm_rst + + + SUBROUTINE tra_osm( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE tra_osm *** + !! + !! ** Purpose : compute and add to the tracer trend the non-local tracer flux + !! + !! ** Method : ??? + !!---------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: ztrdt, ztrds ! 3D workspace + !!---------------------------------------------------------------------- + INTEGER, INTENT(in) :: kt + INTEGER :: ji, jj, jk + ! + IF( kt == nit000 ) THEN + IF(lwp) WRITE(numout,*) + IF(lwp) WRITE(numout,*) 'tra_osm : OSM non-local tracer fluxes' + IF(lwp) WRITE(numout,*) '~~~~~~~ ' + ENDIF + + IF( l_trdtra ) THEN !* Save ta and sa trends + ALLOCATE( ztrdt(jpi,jpj,jpk) ) ; ztrdt(:,:,:) = tsa(:,:,:,jp_tem) + ALLOCATE( ztrds(jpi,jpj,jpk) ) ; ztrds(:,:,:) = tsa(:,:,:,jp_sal) + ENDIF + + ! add non-local temperature and salinity flux + DO jk = 1, jpkm1 + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + tsa(ji,jj,jk,jp_tem) = tsa(ji,jj,jk,jp_tem) & + & - ( ghamt(ji,jj,jk ) & + & - ghamt(ji,jj,jk+1) ) /e3t_n(ji,jj,jk) + tsa(ji,jj,jk,jp_sal) = tsa(ji,jj,jk,jp_sal) & + & - ( ghams(ji,jj,jk ) & + & - ghams(ji,jj,jk+1) ) / e3t_n(ji,jj,jk) + END DO + END DO + END DO + + + ! save the non-local tracer flux trends for diagnostic + IF( l_trdtra ) THEN + ztrdt(:,:,:) = tsa(:,:,:,jp_tem) - ztrdt(:,:,:) + ztrds(:,:,:) = tsa(:,:,:,jp_sal) - ztrds(:,:,:) +!!bug gm jpttdzdf ==> jpttosm + CALL trd_tra( kt, 'TRA', jp_tem, jptra_zdf, ztrdt ) + CALL trd_tra( kt, 'TRA', jp_sal, jptra_zdf, ztrds ) + DEALLOCATE( ztrdt ) ; DEALLOCATE( ztrds ) + ENDIF + + IF(ln_ctl) THEN + CALL prt_ctl( tab3d_1=tsa(:,:,:,jp_tem), clinfo1=' osm - Ta: ', mask1=tmask, & + & tab3d_2=tsa(:,:,:,jp_sal), clinfo2= ' Sa: ', mask2=tmask, clinfo3='tra' ) + ENDIF + ! + 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 ) + !!---------------------------------------------------------------------- + !! *** 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 ! + ! + 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,*) '~~~~~~~ ' + ENDIF + !code saving tracer trends removed, replace with trdmxl_oce + + DO jk = 1, jpkm1 ! add non-local u and v fluxes + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + ua(ji,jj,jk) = ua(ji,jj,jk) & + & - ( ghamu(ji,jj,jk ) & + & - ghamu(ji,jj,jk+1) ) / e3u_n(ji,jj,jk) + va(ji,jj,jk) = va(ji,jj,jk) & + & - ( ghamv(ji,jj,jk ) & + & - ghamv(ji,jj,jk+1) ) / e3v_n(ji,jj,jk) + END DO + END DO + END DO + ! + ! code for saving tracer trends removed + ! + END SUBROUTINE dyn_osm + + !!====================================================================== +END MODULE zdfosm diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfphy.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfphy.F90 new file mode 100644 index 0000000..c5fcece --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfphy.F90 @@ -0,0 +1,357 @@ +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 + 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 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 +#if defined key_agrif + USE agrif_oce_interp ! interpavm +#endif + ! + 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 :: l_zdfsh2 ! shear production term flag (=F for CST, =T otherwise (i.e. TKE, GLS, RIC)) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_phy_init + !!---------------------------------------------------------------------- + !! *** 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 :: 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_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( .NOT. ln_2d ) THEN + + IF(lwp) THEN + WRITE(numout,*) + WRITE(numout,*) 'zdf_phy_init: ocean vertical physics' + WRITE(numout,*) '~~~~~~~~~~~~' + ENDIF + ! + ! !== Namelist ==! + REWIND( numnam_ref ) ! Namelist namzdf in reference namelist : Vertical mixing parameters + READ ( numnam_ref, namzdf, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namzdf in reference namelist : Vertical mixing parameters + 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,*) ' 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 + ! !== 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( 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_stop( 'zdf_phy_init: osmosis 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' + 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 ; 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 ; 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 .OR. ln_zdfgls ) CALL ctl_stop( 'zdf_phy_init: zdfric and zdfgls never tested with ice shelves cavities ' ) + ENDIF + ! ! shear production term flag + IF( ln_zdfcst ) THEN ; l_zdfsh2 = .FALSE. + ELSE ; l_zdfsh2 = .TRUE. + ENDIF + + ! !== 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 + + ENDIF ! .NOT. ln_2d + + ! !== 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 ) + !!---------------------------------------------------------------------- + !! *** 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 :: ji, jj, jk ! dummy loop indice + REAL(wp), DIMENSION(jpi,jpj,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, 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, 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 + + IF( .NOT. ln_2d ) THEN ! 2D case only uses bottom friction from this routine + ! +#if defined key_si3 + IF ( ln_drgice_imp) THEN + IF ( ln_isfcav ) THEN + rCdU_top(:,:) = rCdU_top(:,:) + ssmask(:,:) * tmask(:,:,1) * rCdU_ice(:,:) + ELSE + rCdU_top(:,:) = rCdU_ice(:,:) + ENDIF + ENDIF +#endif + ! + ! !== Kz from chosen turbulent closure ==! (avm_k, avt_k) + ! + IF( l_zdfsh2 ) & !* shear production at w-points (energy conserving form) + CALL zdf_sh2( ub, vb, un, vn, avm_k, & ! <<== in + & zsh2 ) ! ==>> out : shear production + ! + SELECT CASE ( nzdf_phy ) !* Vertical eddy viscosity and diffusivity coefficients at w-points + CASE( np_RIC ) ; CALL zdf_ric( kt, gdept_n, zsh2, avm_k, avt_k ) ! Richardson number dependent Kz + CASE( np_TKE ) ; CALL zdf_tke( kt , zsh2, avm_k, avt_k ) ! TKE closure scheme for Kz + CASE( np_GLS ) ; CALL zdf_gls( kt , zsh2, avm_k, avt_k ) ! GLS closure scheme for Kz + CASE( np_OSM ) ; CALL zdf_osm( kt , 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 + avt(:,:,2:jpkm1) = avt_k(:,:,2:jpkm1) + avm(:,:,2:jpkm1) = avm_k(:,:,2:jpkm1) + ! + IF( ln_rnf_mouth ) THEN !* increase diffusivity at rivers mouths + DO jk = 2, nkrnf + avt(:,:,jk) = avt(:,:,jk) + 2._wp * rn_avt_rnf * rnfmsk(:,:) * wmask(:,:,jk) + END DO + ENDIF + ! + IF( ln_zdfevd ) CALL zdf_evd( kt, avm, avt ) !* convection: enhanced vertical eddy diffusivity + ! + ! !* double diffusive mixing + IF( ln_zdfddm ) THEN ! update avt and compute avs + CALL zdf_ddm( kt, avm, avt, avs ) + ELSE ! same mixing on all tracers + avs(2:jpim1,2:jpjm1,1:jpkm1) = avt(2:jpim1,2:jpjm1,1:jpkm1) + ENDIF + ! + ! !* wave-induced mixing + IF( ln_zdfswm ) CALL zdf_swm( kt, avm, avt, avs ) ! surface wave (Qiao et al. 2004) + IF( ln_zdfiwm ) CALL zdf_iwm( kt, avm, avt, avs ) ! internal wave (de Lavergne et al 2017) + +#if defined key_agrif + ! interpolation parent grid => child grid for avm_k ( ex : at west border: update column 1 and 2) + IF( l_zdfsh2 ) CALL Agrif_avm +#endif + + ! !* Lateral boundary conditions (sign unchanged) + IF( l_zdfsh2 ) THEN + CALL lbc_lnk_multi( 'zdfphy', avm_k, 'W', 1. , avt_k, 'W', 1., & + & avm , 'W', 1. , avt , 'W', 1. , avs , 'W', 1. ) + ELSE + CALL lbc_lnk_multi( 'zdfphy', avm , 'W', 1. , avt , 'W', 1. , avs , 'W', 1. ) + ENDIF + ! + IF( l_zdfdrg ) THEN ! drag have been updated (non-linear cases) + IF( ln_isfcav ) THEN ; CALL lbc_lnk_multi( 'zdfphy', rCdU_top, 'T', 1. , rCdU_bot, 'T', 1. ) ! top & bot drag + ELSE ; CALL lbc_lnk ( 'zdfphy', rCdU_bot, 'T', 1. ) ! bottom drag only + ENDIF + ENDIF + ! + CALL zdf_mxl( kt ) !* mixed layer depth, and level + ! + 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 wn has been updated + ENDIF + + ENDIF ! .NOT. ln_2d + ! + 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/NEMO_4.0.4_surge/src/OCE/ZDF/zdfric.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfric.F90 new file mode 100644 index 0000000..7cc0301 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfric.F90 @@ -0,0 +1,247 @@ +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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namzdf_ric in reference namelist : Vertical diffusion Kz depends on Richardson number + READ ( numnam_ref, namzdf_ric, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_ric in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namzdf_ric in configuration namelist : Vertical diffusion Kz depends on Richardson number + 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 + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('avt_k') + CALL iom_set_rstw_var_active('avm_k') + ENDIF + END SUBROUTINE zdf_ric_init + + + SUBROUTINE zdf_ric( kt, pdept, 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(ub) )+mj( dk(vb) ) ] + !! 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 + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdept ! depth of t-point [m] + REAL(wp), DIMENSION(:,:,:), 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(jpi,jpj) :: zh_ekm ! 2D workspace + !!---------------------------------------------------------------------- + ! + ! !== avm and avt = F(Richardson number) ==! + DO jk = 2, jpkm1 + DO jj = 1, jpjm1 + DO ji = 1, jpim1 ! 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 = 2, jpjm1 !* Ekman depth + DO ji = 2, jpim1 + zustar = SQRT( taum(ji,jj) * r1_rau0 ) + 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 !* minimum mixing coeff. within the Ekman layer + DO jj = 2, jpjm1 + DO ji = 2, jpim1 + IF( pdept(ji,jj,jk) < 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_autoglo, 'avt_k', avt_k, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios ) + 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 ----' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios) + IF( lwxios ) CALL iom_swap( cxios_context ) + ! + ENDIF + ! + END SUBROUTINE ric_rst + + !!====================================================================== +END MODULE zdfric diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfsh2.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfsh2.F90 new file mode 100644 index 0000000..16dd1fc --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfsh2.F90 @@ -0,0 +1,79 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! zdf_sh2 : compute mixing the shear production term of TKE + !!---------------------------------------------------------------------- + USE dom_oce ! domain: ocean + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC zdf_sh2 ! called by zdftke, zdfglf, and zdfric + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_sh2( pub, pvb, pun, pvn, 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 + !! --------------------------------------------------------------------- + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pub, pvb, pun, pvn ! before, now horizontal velocities + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_avm ! vertical eddy viscosity (w-points) + REAL(wp), DIMENSION(:,:,:) , INTENT( out) :: p_sh2 ! shear production of TKE (w-points) + ! + INTEGER :: ji, jj, jk ! dummy loop arguments + REAL(wp), DIMENSION(jpi,jpj) :: zsh2u, zsh2v ! 2D workspace + !!-------------------------------------------------------------------- + ! + DO jk = 2, jpkm1 + DO jj = 1, jpjm1 !* 2 x shear production at uw- and vw-points (energy conserving form) + DO ji = 1, jpim1 + zsh2u(ji,jj) = ( p_avm(ji+1,jj,jk) + p_avm(ji,jj,jk) ) & + & * ( pun(ji,jj,jk-1) - pun(ji,jj,jk) ) & + & * ( pub(ji,jj,jk-1) - pub(ji,jj,jk) ) / ( e3uw_n(ji,jj,jk) * e3uw_b(ji,jj,jk) ) * wumask(ji,jj,jk) + zsh2v(ji,jj) = ( p_avm(ji,jj+1,jk) + p_avm(ji,jj,jk) ) & + & * ( pvn(ji,jj,jk-1) - pvn(ji,jj,jk) ) & + & * ( pvb(ji,jj,jk-1) - pvb(ji,jj,jk) ) / ( e3vw_n(ji,jj,jk) * e3vw_b(ji,jj,jk) ) * wvmask(ji,jj,jk) + END DO + END DO + DO jj = 2, jpjm1 !* shear production at w-point + DO ji = 2, jpim1 ! 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 + ! + END SUBROUTINE zdf_sh2 + + !!====================================================================== +END MODULE zdfsh2 diff --git a/NEMO_4.0.4_surge/src/OCE/ZDF/zdfswm.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfswm.F90 new file mode 100644 index 0000000..c0fb869 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdfswm.F90 @@ -0,0 +1,97 @@ +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 + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE zdf_swm( kt, 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 + 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 = 2, jpjm1 + DO ji = 2, jpim1 + zqb = zcoef * hsw(ji,jj) * tsd2d(ji,jj) * EXP( -3. * wnum(ji,jj) * gdepw_n(ji,jj,jk) ) * 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/NEMO_4.0.4_surge/src/OCE/ZDF/zdftke.F90 b/NEMO_4.0.4_surge/src/OCE/ZDF/zdftke.F90 new file mode 100644 index 0000000..9573e5e --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/ZDF/zdftke.F90 @@ -0,0 +1,898 @@ +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 + !!---------------------------------------------------------------------- + + !!---------------------------------------------------------------------- + !! 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 + ! +#if defined key_si3 + USE ice, ONLY: hm_i, h_i +#endif +#if defined key_cice + USE sbc_ice, ONLY: h_i +#endif + 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) + + 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 + 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) + 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 +# include "vectopt_loop_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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, 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 + REAL(wp), DIMENSION(:,:,:), 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( gdepw_n, e3t_n, e3w_n, p_sh2, p_avm, p_avt ) ! now tke (en) + ! + CALL tke_avn( gdepw_n, e3t_n, e3w_n, p_avm, p_avt ) ! now avt, avm, dissl + ! + END SUBROUTINE zdf_tke + + + SUBROUTINE tke_tke( pdepw, p_e3t, p_e3w, 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 + !! + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: pdepw ! depth of w-points + REAL(wp), DIMENSION(:,:,:) , INTENT(in ) :: p_e3t, p_e3w ! level thickness (t- & w-points) + REAL(wp), DIMENSION(:,:,:) , 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 ! - - + INTEGER , DIMENSION(jpi,jpj) :: imlc + REAL(wp), DIMENSION(jpi,jpj) :: zice_fra, zhlc, zus3 + REAL(wp), DIMENSION(jpi,jpj,jpk) :: zpelc, zdiag, zd_up, zd_lw + !!-------------------------------------------------------------------- + ! + zbbrau = rn_ebb / rau0 ! Local constant initialisation + zbbirau = 3.75_wp / rau0 + zfact1 = -0.5_wp * rdt + zfact2 = 1.5_wp * rdt * rn_ediss + zfact3 = 0.5_wp * rn_ediss + ! + ! 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(:,:) * 10._wp ) + CASE( 2 ) ; zice_fra(:,:) = fr_i(:,:) + CASE( 3 ) ; zice_fra(:,:) = MIN( 4._wp * fr_i(:,:) , 1._wp ) + END SELECT + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Surface/top/bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + DO jj = 2, jpjm1 ! en(1) = rn_ebb taum / rau0 (min value rn_emin0) + DO ji = fs_2, fs_jpim1 ! vector opt. +!! clem: this should be the right formulation but it makes the model unstable unless drags are calculated implicitly +!! one way around would be to increase zbbirau +!! en(ji,jj,1) = MAX( rn_emin0, ( ( 1._wp - fr_i(ji,jj) ) * zbbrau + & +!! & fr_i(ji,jj) * zbbirau ) * taum(ji,jj) ) * tmask(ji,jj,1) + en(ji,jj,1) = MAX( rn_emin0, zbbrau * taum(ji,jj) ) * tmask(ji,jj,1) + END DO + END DO + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! Bottom boundary condition on tke + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! + ! en(bot) = (ebb0/rau0)*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 = 2, jpjm1 ! bottom friction + DO ji = fs_2, fs_jpim1 ! vector opt. + 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/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) + zebot = - 0.001875_wp * rCdU_bot(ji,jj) * SQRT( ( zmsku*( ub(ji,jj,mbkt(ji,jj))+ub(ji-1,jj,mbkt(ji,jj)) ) )**2 & + & + ( zmskv*( vb(ji,jj,mbkt(ji,jj))+vb(ji,jj-1,mbkt(ji,jj)) ) )**2 ) + en(ji,jj,mbkt(ji,jj)+1) = MAX( zebot, rn_emin ) * ssmask(ji,jj) + END DO + END DO + IF( ln_isfcav ) THEN ! top friction + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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/rau0) * 0.5 = 3.75*0.5/1000. (CAUTION CdU<0) + zetop = - 0.001875_wp * rCdU_top(ji,jj) * SQRT( ( zmsku*( ub(ji,jj,mikt(ji,jj))+ub(ji-1,jj,mikt(ji,jj)) ) )**2 & + & + ( zmskv*( vb(ji,jj,mikt(ji,jj))+vb(ji,jj-1,mikt(ji,jj)) ) )**2 ) + 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) + ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! + ! !* total energy produce by LC : cumulative sum over jk + zpelc(:,:,1) = MAX( rn2b(:,:,1), 0._wp ) * pdepw(:,:,1) * p_e3w(:,:,1) + DO jk = 2, jpk + zpelc(:,:,jk) = zpelc(:,:,jk-1) + MAX( rn2b(:,:,jk), 0._wp ) * pdepw(:,:,jk) * p_e3w(:,:,jk) + END DO + ! !* finite Langmuir Circulation depth + zcof = 0.5 * 0.016 * 0.016 / ( zrhoa * zcdrag ) + imlc(:,:) = mbkt(:,:) + 1 ! Initialization to the number of w ocean point (=2 over land) + DO jk = jpkm1, 2, -1 + DO jj = 1, jpj ! Last w-level at which zpelc>=0.5*us*us + DO ji = 1, jpi ! with us=0.016*wind(starting from jpk-1) + zus = zcof * taum(ji,jj) + IF( zpelc(ji,jj,jk) > zus ) imlc(ji,jj) = jk + END DO + END DO + END DO + ! ! finite LC depth + DO jj = 1, jpj + DO ji = 1, jpi + zhlc(ji,jj) = pdepw(ji,jj,imlc(ji,jj)) + END DO + END DO + zcof = 0.016 / SQRT( zrhoa * zcdrag ) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zus = zcof * SQRT( taum(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 !* TKE Langmuir circulation source term added to en + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + IF ( zus3(ji,jj) /= 0._wp ) THEN + ! vertical velocity due to LC + IF ( pdepw(ji,jj,jk) - zhlc(ji,jj) < 0 .AND. wmask(ji,jj,jk) /= 0. ) THEN + ! ! vertical velocity due to LC + zwlc = rn_lc * SIN( rpi * pdepw(ji,jj,jk) / zhlc(ji,jj) ) + ! ! TKE Langmuir circulation source term + en(ji,jj,jk) = en(ji,jj,jk) + rdt * 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 = 2, jpjm1 + DO ji = 2, jpim1 + ! ! local Richardson number + zri = MAX( rn2b(ji,jj,jk), 0._wp ) * p_avm(ji,jj,jk) / ( p_sh2(ji,jj,jk) + rn_bshear ) + ! ! 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 !* Matrix and right hand side in en + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 + & / ( p_e3t(ji,jj,jk ) * p_e3w(ji,jj,jk ) ) + zzd_lw = zcof * MAX( p_avm(ji,jj,jk ) + p_avm(ji,jj,jk-1) , 2.e-5_wp ) & ! lower diagonal + & / ( p_e3t(ji,jj,jk-1) * p_e3w(ji,jj,jk ) ) + ! + 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) + rdt * ( 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 + ! !* Matrix inversion from level 2 (tke prescribed at level 1) + DO jk = 3, jpkm1 ! First recurrence : Dk = Dk - Lk * Uk-1 / Dk-1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 jj = 2, jpjm1 ! Second recurrence : Lk = RHSk - Lk / Dk-1 * Lk-1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 3, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 ! thrid recurrence : Ek = ( Lk - Uk * Ek+1 ) / Dk + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 ! set the minimum value of tke + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + en(ji,jj,jk) = MAX( en(ji,jj,jk), rn_emin ) * wmask(ji,jj,jk) + END DO + END DO + END DO + ! + ! !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! ! 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 (pdepw) + + + IF( nn_etau == 1 ) THEN !* penetration below the mixed layer (rn_efr fraction) + DO jk = 2, jpkm1 ! nn_eice=0 : ON below sea-ice ; nn_eice>0 : partly OFF + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + jk = nmln(ji,jj) + en(ji,jj,jk) = en(ji,jj,jk) + rn_efr * en(ji,jj,1) * EXP( -pdepw(ji,jj,jk) / 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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( -pdepw(ji,jj,jk) / 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( pdepw, p_e3t, p_e3w, 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 + !! + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: pdepw ! depth (w-points) + REAL(wp), DIMENSION(:,:,:), INTENT(in ) :: p_e3t, p_e3w ! level thickness (t- & 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(wp) :: zrn2, zraug, zcoef, zav ! local scalars + REAL(wp) :: zdku, zdkv, zsqen ! - - + REAL(wp) :: zemxl, zemlm, zemlp, zmaxice ! - - + REAL(wp), DIMENSION(jpi,jpj,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_mxl0 ) THEN ! surface mixing length = F(stress) : l=vkarmn*2.e5*taum/(rau0*g) + ! + zraug = vkarmn * 2.e5_wp / ( rau0 * grav ) +#if ! defined key_si3 && ! defined key_cice + DO jj = 2, jpjm1 ! No sea-ice + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) + END DO + END DO +#else + + SELECT CASE( nn_mxlice ) ! Type of scaling under sea-ice + ! + CASE( 0 ) ! No scaling under sea-ice + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = zraug * taum(ji,jj) * tmask(ji,jj,1) + END DO + END DO + ! + CASE( 1 ) ! scaling with constant sea-ice thickness + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * rn_mxlice ) * tmask(ji,jj,1) + END DO + END DO + ! + CASE( 2 ) ! scaling with mean sea-ice thickness + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 +#if defined key_si3 + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * hm_i(ji,jj) * 2._wp ) * tmask(ji,jj,1) +#elif defined key_cice + zmaxice = MAXVAL( h_i(ji,jj,:) ) + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) +#endif + END DO + END DO + ! + CASE( 3 ) ! scaling with max sea-ice thickness + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zmaxice = MAXVAL( h_i(ji,jj,:) ) + zmxlm(ji,jj,1) = ( ( 1._wp - fr_i(ji,jj) ) * zraug * taum(ji,jj) + & + & fr_i(ji,jj) * zmaxice ) * tmask(ji,jj,1) + END DO + END DO + ! + END SELECT +#endif + ! + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 + zmxlm(ji,jj,1) = MAX( rn_mxl0, zmxlm(ji,jj,1) ) + END DO + END DO + ! + ELSE + zmxlm(:,:,1) = rn_mxl0 + ENDIF + ! + DO jk = 2, jpkm1 ! interior value : l=sqrt(2*e/n^2) + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 == p_e3w + CASE ( 0 ) ! bounded by the distance to surface and bottom + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zemxl = MIN( pdepw(ji,jj,jk) - pdepw(ji,jj,mikt(ji,jj)), zmxlm(ji,jj,jk), & + & pdepw(ji,jj,mbkt(ji,jj)+1) - pdepw(ji,jj,jk) ) + ! wmask prevent zmxlm = 0 if jk = mikt(ji,jj) + zmxlm(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (1 - wmask(ji,jj,jk)) + zmxld(ji,jj,jk) = zemxl * wmask(ji,jj,jk) + MIN( zmxlm(ji,jj,jk) , p_e3w(ji,jj,jk) ) * (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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zemxl = MIN( p_e3w(ji,jj,jk), 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 ! from the surface to the bottom : + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) + END DO + END DO + END DO + DO jk = jpkm1, 2, -1 ! from the bottom to the surface : + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zemxl = MIN( zmxlm(ji,jj,jk+1) + p_e3t(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 ! from the surface to the bottom : lup + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zmxld(ji,jj,jk) = MIN( zmxld(ji,jj,jk-1) + p_e3t(ji,jj,jk-1), zmxlm(ji,jj,jk) ) + END DO + END DO + END DO + DO jk = jpkm1, 2, -1 ! from the bottom to the surface : ldown + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + zmxlm(ji,jj,jk) = MIN( zmxlm(ji,jj,jk+1) + p_e3t(ji,jj,jk+1), zmxlm(ji,jj,jk) ) + END DO + END DO + END DO + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 !* vertical eddy viscosity & diffivity at w-points + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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 = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + 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(ln_ctl) THEN + CALL prt_ctl( tab3d_1=en , clinfo1=' tke - e: ', tab3d_2=p_avt, clinfo2=' t: ', kdim=jpk) + CALL prt_ctl( tab3d_1=p_avm, clinfo1=' tke - m: ', kdim=jpk ) + ENDIF + ! + END SUBROUTINE tke_avn + + + SUBROUTINE zdf_tke_init + !!---------------------------------------------------------------------- + !! *** 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 :: 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 + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namzdf_tke in reference namelist : Turbulent Kinetic Energy + READ ( numnam_ref, namzdf_tke, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namzdf_tke in reference namelist' ) + + REWIND( numnam_cfg ) ! Namelist namzdf_tke in configuration namelist : Turbulent Kinetic Energy + 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 + 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 + IF( .NOT.ln_drg_OFF ) THEN + WRITE(numout,*) + WRITE(numout,*) ' Namelist namdrg_top/_bot: used values:' + WRITE(numout,*) ' top ocean cavity roughness (m) rn_z0(_top)= ', r_z0_top + WRITE(numout,*) ' Bottom seafloor roughness (m) rn_z0(_bot)= ', r_z0_bot + ENDIF + 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 or 2 ' ) + 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, 1 or 2 ' ) + 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 + + IF( nn_etau == 2 ) CALL zdf_mxl( nit000 ) ! Initialization of nmln + + ! !* 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) + ! + IF( lwxios ) THEN + CALL iom_set_rstw_var_active('en') + CALL iom_set_rstw_var_active('avt_k') + CALL iom_set_rstw_var_active('avm_k') + CALL iom_set_rstw_var_active('dissl') + ENDIF + 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_autoglo, 'en' , en , ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'avt_k', avt_k, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'avm_k', avm_k, ldxios = lrxios ) + CALL iom_get( numror, jpdom_autoglo, 'dissl', dissl, ldxios = lrxios ) + 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 ----' + IF( lwxios ) CALL iom_swap( cwxios_context ) + CALL iom_rstput( kt, nitrst, numrow, 'en' , en , ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'avt_k', avt_k, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'avm_k', avm_k, ldxios = lwxios ) + CALL iom_rstput( kt, nitrst, numrow, 'dissl', dissl, ldxios = lwxios ) + IF( lwxios ) CALL iom_swap( cxios_context ) + ! + ENDIF + ! + END SUBROUTINE tke_rst + + !!====================================================================== +END MODULE zdftke diff --git a/NEMO_4.0.4_surge/src/OCE/lib_cray.f90 b/NEMO_4.0.4_surge/src/OCE/lib_cray.f90 new file mode 100644 index 0000000..2fef649 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/lib_cray.f90 @@ -0,0 +1,34 @@ +! Cray subroutines or functions used by OPA model and possibly +! not found on other platforms. +! +! check their existence +! +! wheneq + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +SUBROUTINE lib_cray + WRITE(*,*) 'lib_cray: You should not have seen this print! error?' +END SUBROUTINE lib_cray + +SUBROUTINE wheneq ( i, x, j, t, ind, nn ) + IMPLICIT NONE + + INTEGER , INTENT ( in ) :: i, j + INTEGER , INTENT ( out ) :: nn + REAL , INTENT ( in ), DIMENSION (1+(i-1)*j) :: x + REAL , INTENT ( in ) :: t + INTEGER , INTENT ( out ), DIMENSION (1+(i-1)*j) :: ind + INTEGER :: n, k + nn = 0 + DO n = 1, i + k = 1 + (n-1) * j + IF ( x ( k) == t ) THEN + nn = nn + 1 + ind (nn) = k + ENDIF + END DO + +END SUBROUTINE wheneq diff --git a/NEMO_4.0.4_surge/src/OCE/lib_fortran.F90 b/NEMO_4.0.4_surge/src/OCE/lib_fortran.F90 new file mode 100644 index 0000000..321eca4 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/lib_fortran.F90 @@ -0,0 +1,489 @@ +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) + PUBLIC glob_sum_full ! used in many places (masked with tmask_h, ie only over the halos) + 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 +#if defined key_nosignedzero + PUBLIC SIGN +#endif + + INTERFACE glob_sum + MODULE PROCEDURE glob_sum_1d, glob_sum_2d, glob_sum_3d + END INTERFACE + INTERFACE glob_sum_full + MODULE PROCEDURE glob_sum_full_2d, glob_sum_full_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 + +#if defined key_nosignedzero + INTERFACE SIGN + MODULE PROCEDURE SIGN_SCALAR, SIGN_ARRAY_1D, SIGN_ARRAY_2D, SIGN_ARRAY_3D, & + & SIGN_ARRAY_1D_A, SIGN_ARRAY_2D_A, SIGN_ARRAY_3D_A, & + & SIGN_ARRAY_1D_B, SIGN_ARRAY_2D_B, SIGN_ARRAY_3D_B + END INTERFACE +#endif + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + +# define GLOBSUM_CODE + +# define DIM_1d +# define FUNCTION_GLOBSUM glob_sum_1d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBSUM +# undef DIM_1d + +# define DIM_2d +# define OPERATION_GLOBSUM +# define FUNCTION_GLOBSUM glob_sum_2d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBSUM +# undef OPERATION_GLOBSUM +# define OPERATION_FULL_GLOBSUM +# define FUNCTION_GLOBSUM glob_sum_full_2d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBSUM +# undef OPERATION_FULL_GLOBSUM +# undef DIM_2d + +# define DIM_3d +# define OPERATION_GLOBSUM +# define FUNCTION_GLOBSUM glob_sum_3d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBSUM +# undef OPERATION_GLOBSUM +# define OPERATION_FULL_GLOBSUM +# define FUNCTION_GLOBSUM glob_sum_full_3d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBSUM +# undef OPERATION_FULL_GLOBSUM +# undef DIM_3d + +# undef GLOBSUM_CODE + + +# define GLOBMINMAX_CODE + +# define DIM_2d +# define OPERATION_GLOBMIN +# define FUNCTION_GLOBMINMAX glob_min_2d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBMINMAX +# undef OPERATION_GLOBMIN +# define OPERATION_GLOBMAX +# define FUNCTION_GLOBMINMAX glob_max_2d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBMINMAX +# undef OPERATION_GLOBMAX +# undef DIM_2d + +# define DIM_3d +# define OPERATION_GLOBMIN +# define FUNCTION_GLOBMINMAX glob_min_3d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBMINMAX +# undef OPERATION_GLOBMIN +# define OPERATION_GLOBMAX +# define FUNCTION_GLOBMINMAX glob_max_3d +# include "lib_fortran_generic.h90" +# undef FUNCTION_GLOBMINMAX +# undef OPERATION_GLOBMAX +# undef DIM_3d +# undef GLOBMINMAX_CODE + +! ! FUNCTION local_sum ! + + FUNCTION local_sum_2d( ptab ) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: ptab(:,:) ! array on which operation is applied + COMPLEX(wp) :: local_sum_2d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(wp):: ctmp + REAL(wp) :: 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, wp ) ! 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, wp ), ctmp ) + END DO + END DO + ! + local_sum_2d = ctmp + + END FUNCTION local_sum_2d + + FUNCTION local_sum_3d( ptab ) + !!---------------------------------------------------------------------- + REAL(wp), INTENT(in ) :: ptab(:,:,:) ! array on which operation is applied + COMPLEX(wp) :: local_sum_3d + ! + !!----------------------------------------------------------------------- + ! + COMPLEX(wp):: ctmp + REAL(wp) :: 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, wp ) ! 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, wp ), 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' ) + ! + DO jj = 1, jpj + DO ji = 1, jpi + IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber 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. ) + IF( nbondi /= -1 ) THEN + IF( MOD(mig( 1), 3) == 1 ) p2d( 1,:) = p2d( 2,:) + IF( MOD(mig( 1), 3) == 2 ) p2d( 2,:) = p2d( 1,:) + ENDIF + IF( nbondi /= 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( nbondj /= -1 ) THEN + IF( MOD(mjg( 1), 3) == 1 ) p2d(:, 1) = p2d(:, 2) + IF( MOD(mjg( 1), 3) == 2 ) p2d(:, 2) = p2d(:, 1) + ENDIF + IF( nbondj /= 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. ) + + 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 + DO jj = 1, jpj + DO ji = 1, jpi + IF( MOD(mig(ji), 3) == 1 .AND. MOD(mjg(jj), 3) == 1 ) THEN ! bottom left corber 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. ) + IF( nbondi /= -1 ) THEN + IF( MOD(mig( 1), 3) == 1 ) p3d( 1,:,:) = p3d( 2,:,:) + IF( MOD(mig( 1), 3) == 2 ) p3d( 2,:,:) = p3d( 1,:,:) + ENDIF + IF( nbondi /= 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( nbondj /= -1 ) THEN + IF( MOD(mjg( 1), 3) == 1 ) p3d(:, 1,:) = p3d(:, 2,:) + IF( MOD(mjg( 1), 3) == 2 ) p3d(:, 2,:) = p3d(:, 1,:) + ENDIF + IF( nbondj /= 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. ) + + END SUBROUTINE sum3x3_3d + + + 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 useing 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(wp), INTENT(in ) :: ydda + COMPLEX(wp), INTENT(inout) :: yddb + ! + REAL(wp) :: 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), wp ) + ! + END SUBROUTINE DDPDD + +#if defined key_nosignedzero + !!---------------------------------------------------------------------- + !! 'key_nosignedzero' F90 SIGN + !!---------------------------------------------------------------------- + + FUNCTION SIGN_SCALAR( pa, pb ) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_SCALAR *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb ! input + REAL(wp) :: SIGN_SCALAR ! result + !!----------------------------------------------------------------------- + IF ( pb >= 0.e0) THEN ; SIGN_SCALAR = ABS(pa) + ELSE ; SIGN_SCALAR =-ABS(pa) + ENDIF + END FUNCTION SIGN_SCALAR + + + FUNCTION SIGN_ARRAY_1D( pa, pb ) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_1D *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb(:) ! input + REAL(wp) :: SIGN_ARRAY_1D(SIZE(pb,1)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_1D =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_1D + + + FUNCTION SIGN_ARRAY_2D(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_2D *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb(:,:) ! input + REAL(wp) :: SIGN_ARRAY_2D(SIZE(pb,1),SIZE(pb,2)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_2D =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_2D + + FUNCTION SIGN_ARRAY_3D(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_3D *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa,pb(:,:,:) ! input + REAL(wp) :: SIGN_ARRAY_3D(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_3D =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_3D + + + FUNCTION SIGN_ARRAY_1D_A(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_1D_A *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:),pb(:) ! input + REAL(wp) :: SIGN_ARRAY_1D_A(SIZE(pb,1)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_1D_A = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_1D_A =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_1D_A + + + FUNCTION SIGN_ARRAY_2D_A(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_2D_A *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:),pb(:,:) ! input + REAL(wp) :: SIGN_ARRAY_2D_A(SIZE(pb,1),SIZE(pb,2)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_2D_A = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_2D_A =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_2D_A + + + FUNCTION SIGN_ARRAY_3D_A(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_3D_A *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:,:),pb(:,:,:) ! input + REAL(wp) :: SIGN_ARRAY_3D_A(SIZE(pb,1),SIZE(pb,2),SIZE(pb,3)) ! result + !!----------------------------------------------------------------------- + WHERE ( pb >= 0.e0 ) ; SIGN_ARRAY_3D_A = ABS(pa) + ELSEWHERE ; SIGN_ARRAY_3D_A =-ABS(pa) + END WHERE + END FUNCTION SIGN_ARRAY_3D_A + + + FUNCTION SIGN_ARRAY_1D_B(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_1D_B *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:),pb ! input + REAL(wp) :: SIGN_ARRAY_1D_B(SIZE(pa,1)) ! result + !!----------------------------------------------------------------------- + IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_1D_B = ABS(pa) + ELSE ; SIGN_ARRAY_1D_B =-ABS(pa) + ENDIF + END FUNCTION SIGN_ARRAY_1D_B + + + FUNCTION SIGN_ARRAY_2D_B(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_2D_B *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:),pb ! input + REAL(wp) :: SIGN_ARRAY_2D_B(SIZE(pa,1),SIZE(pa,2)) ! result + !!----------------------------------------------------------------------- + IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_2D_B = ABS(pa) + ELSE ; SIGN_ARRAY_2D_B =-ABS(pa) + ENDIF + END FUNCTION SIGN_ARRAY_2D_B + + + FUNCTION SIGN_ARRAY_3D_B(pa,pb) + !!----------------------------------------------------------------------- + !! *** FUNCTION SIGN_ARRAY_3D_B *** + !! + !! ** Purpose : overwrite f95 behaviour of intrinsinc sign function + !!----------------------------------------------------------------------- + REAL(wp) :: pa(:,:,:),pb ! input + REAL(wp) :: SIGN_ARRAY_3D_B(SIZE(pa,1),SIZE(pa,2),SIZE(pa,3)) ! result + !!----------------------------------------------------------------------- + IF( pb >= 0.e0 ) THEN ; SIGN_ARRAY_3D_B = ABS(pa) + ELSE ; SIGN_ARRAY_3D_B =-ABS(pa) + ENDIF + END FUNCTION SIGN_ARRAY_3D_B +#endif + + !!====================================================================== +END MODULE lib_fortran diff --git a/NEMO_4.0.4_surge/src/OCE/lib_fortran_generic.h90 b/NEMO_4.0.4_surge/src/OCE/lib_fortran_generic.h90 new file mode 100644 index 0000000..7898cde --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/lib_fortran_generic.h90 @@ -0,0 +1,139 @@ +#if defined GLOBSUM_CODE +! ! FUNCTION FUNCTION_GLOBSUM ! +# if defined DIM_1d +# define ARRAY_TYPE(i,j,k) REAL(wp) , 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 ARRAY_TYPE(i,j,k) REAL(wp) , 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 +# endif +# if defined DIM_3d +# define ARRAY_TYPE(i,j,k) REAL(wp) , 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) +# endif +# if defined OPERATION_GLOBSUM +# define MASK_ARRAY(i,j) tmask_i(i,j) +# endif +# if defined OPERATION_FULL_GLOBSUM +# define MASK_ARRAY(i,j) tmask_h(i,j) +# endif + + FUNCTION FUNCTION_GLOBSUM( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which operation is applied + REAL(wp) :: FUNCTION_GLOBSUM + ! + !!----------------------------------------------------------------------- + ! + REAL(wp) :: FUNCTION_GLOB_OP ! global sum + !! + COMPLEX(wp):: ctmp + REAL(wp) :: ztmp + INTEGER :: ji, jj, jk ! dummy loop indices + INTEGER :: ipi, ipj, ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipi = SIZE(ptab,1) ! 1st dimension + ipj = J_SIZE(ptab) ! 2nd dimension + ipk = K_SIZE(ptab) ! 3rd dimension + ! + ctmp = CMPLX( 0.e0, 0.e0, wp ) ! warning ctmp is cumulated + + DO jk = 1, ipk + DO jj = 1, ipj + DO ji = 1, ipi + ztmp = ARRAY_IN(ji,jj,jk) * MASK_ARRAY(ji,jj) + CALL DDPDD( CMPLX( ztmp, 0.e0, wp ), ctmp ) + END DO + END DO + END DO + CALL mpp_sum( cdname, ctmp ) ! sum over the global domain + FUNCTION_GLOBSUM = REAL(ctmp,wp) + + END FUNCTION FUNCTION_GLOBSUM + +#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 ARRAY_TYPE(i,j,k) REAL(wp) , 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 ARRAY_TYPE(i,j,k) REAL(wp) , 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 SCALAR_OPERATION min +# define ARRAY_OPERATION minval +# define MPP_OPERATION mpp_min +# endif +# if defined OPERATION_GLOBMAX +# define SCALAR_OPERATION max +# define ARRAY_OPERATION maxval +# define MPP_OPERATION mpp_max +# endif + + FUNCTION FUNCTION_GLOBMINMAX( cdname, ptab ) + !!---------------------------------------------------------------------- + CHARACTER(len=*), INTENT(in ) :: cdname ! name of the calling subroutine + ARRAY_TYPE(:,:,:) ! array on which operation is applied + REAL(wp) :: FUNCTION_GLOBMINMAX + ! + !!----------------------------------------------------------------------- + ! + REAL(wp) :: FUNCTION_GLOB_OP ! global sum + !! + COMPLEX(wp):: ctmp + REAL(wp) :: ztmp + INTEGER :: jk ! dummy loop indices + INTEGER :: ipk ! dimensions + !!----------------------------------------------------------------------- + ! + ipk = K_SIZE(ptab) ! 3rd dimension + ! + ztmp = ARRAY_OPERATION( ARRAY_IN(:,:,1)*tmask_i(:,:) ) + DO jk = 2, ipk + ztmp = SCALAR_OPERATION(ztmp, ARRAY_OPERATION( ARRAY_IN(:,:,jk)*tmask_i(:,:) )) + ENDDO + + CALL MPP_OPERATION( cdname, ztmp) + + FUNCTION_GLOBMINMAX = ztmp + + + END FUNCTION FUNCTION_GLOBMINMAX + +#undef ARRAY_TYPE +#undef ARRAY2_TYPE +#undef ARRAY_IN +#undef ARRAY2_IN +#undef K_SIZE +#undef SCALAR_OPERATION +#undef ARRAY_OPERATION +#undef MPP_OPERATION +# endif diff --git a/NEMO_4.0.4_surge/src/OCE/module_example b/NEMO_4.0.4_surge/src/OCE/module_example new file mode 100644 index 0000000..b4d3d73 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/module_example @@ -0,0 +1,194 @@ +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) - - + !!---------------------------------------------------------------------- +#if defined key_example + !!---------------------------------------------------------------------- + !! 'key_example' : brief description of the key option + !!---------------------------------------------------------------------- + !! exa_mpl : list of module subroutine (caution, never use the + !! exa_mpl_init : name of the module for a routine) + !! exa_mpl_stp : Please try to use 3 letter block for routine names + !!---------------------------------------------------------------------- + USE module_name1 ! brief description of the used module + USE module_name2 ! .... + + IMPLICIT NONE + PRIVATE + + PUBLIC exa_mpl ! routine called in xxx.F90 module + PUBLIC exa_mpl_init ! routine called in nemogcm.F90 module + + TYPE :: FLD_E !: Structure type definition + CHARACTER(lc) :: clname ! clname description (default length, lc, is 256, see par_kind.F90) + INTEGER :: nfreqh ! nfreqh description + END TYPE FLD_E + + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: var1 !: var1 description. CAUTION always use !: to describe + ! ! a PUBLIC variable: simplify its search : + ! ! grep var1 *90 | grep '!:' + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: var2, var2 !: several variable on a same line OK, but + ! ! DO NOT use continuation lines in declaration + + ! !!* namelist nam_xxx * + LOGICAL :: ln_opt = .TRUE. ! give the default value of each namelist parameter + CHARACTER :: cn_tex = 'T' ! short description of the variable + INTEGER :: nn_opt = 1 ! please respect the DOCTOR norm for namelist variable + REAL(wp) :: rn_var = 2._wp ! (it becomes easy to identify them in the code) + TYPE(FLD) :: sn_ex ! structure + + INTEGER :: nint ! nint description (local permanent variable) + REAL(wp) :: var ! var - - + REAL(wp), ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: array ! array - - + + !! * Substitutions +# include "exampl_substitute.h90" + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id: module_example 11536 2019-09-11 13:54:18Z smasson $ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION exa_mpl_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION exa_mpl_alloc *** + !!---------------------------------------------------------------------- + ALLOCATE( array(jpi,jpj,jpk) , STAT= exa_mpl_alloc ) ! Module array + ! + CALL mpp_sum ( 'module_example', exa_mpl_alloc ) + IF( exa_mpl_alloc /= 0 ) CALL ctl_stop( 'STOP', 'exa_mpl_alloc: failed to allocate arrays' ) + ! + END FUNCTION exa_mpl_alloc + + + SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab ) + !!---------------------------------------------------------------------- + !! *** ROUTINE exa_mpl *** + !! + !! ** Purpose : Brief description of the routine + !! + !! ** Method : description of the methodoloy used to achieve the + !! objectives of the routine. Be as clear as possible! + !! + !! ** Action : - first action (share memory array/varible modified + !! in this routine + !! - second action ..... + !! - ..... + !! + !! References : Author et al., Short_name_review, Year + !! Give references if exist otherwise suppress these lines + !!---------------------------------------------------------------------- + INTEGER , INTENT(in ) :: kt ! short description + INTEGER , INTENT(inout) :: pvar1 ! - - + REAL(wp), INTENT( out) :: pvar2 ! - - + REAL(wp), INTENT( out), DIMENSION(jpi,jpj) :: pvar2 ! - - + !! + INTEGER :: ji, jj, jk ! dummy loop arguments (DOCTOR : start with j, but not jp) + INTEGER :: itoto, itata ! temporary integers (DOCTOR : start with i + REAL(wp) :: zmlmin, zbbrau ! temporary scalars (DOCTOR : start with z) + REAL(wp) :: zfact1, zfact2 ! do not use continuation lines in declaration + REAL(wp), DIMENSION(jpi,jpj) :: zwrk_2d ! 2D workspace + !!-------------------------------------------------------------------- + ! + IF( kt == nit000 ) CALL exa_mpl_init ! Initialization (first time-step only) + + zmlmin = 1.e-8 ! Local constant initialization + zbbrau = .5 * ebb / rau0 + zfact1 = -.5 * rdt * efave + zfact2 = 1.5 * rdt * ediss + + SELECT CASE ( npdl ) ! short description of the action + ! + CASE ( 0 ) ! describe case 1 + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + avm(ji,jj,jk) = .... + END DO + END DO + END DO + ! + CASE ( 1 ) ! describe case 2 + DO jk = 2, jpkm1 + DO jj = 2, jpjm1 + DO ji = fs_2, fs_jpim1 ! vector opt. + avm(ji,jj,jk) = ... + END DO + END DO + END DO + ! + END SELECT + ! + CALL lbc_lnk( 'module_example', avm, 'T', 1. ) ! Lateral boundary conditions (unchanged sign) + ! + END SUBROUTINE exa_mpl + + + SUBROUTINE exa_mpl_init + !!---------------------------------------------------------------------- + !! *** ROUTINE exa_mpl_init *** + !! + !! ** Purpose : initialization of .... + !! + !! ** Method : blah blah blah ... + !! + !! ** input : Namlist namexa + !! + !! ** Action : ... + !!---------------------------------------------------------------------- + INTEGER :: ji, jj, jk, jit ! dummy loop indices + INTEGER :: ios ! Local integer output status for namelist read + !! + NAMELIST/namexa/ exa_v1, exa_v2, nexa_0, sn_ex + !!---------------------------------------------------------------------- + ! + REWIND( numnam_ref ) ! Namelist namexa in reference namelist : Example + READ ( numnam_ref, namexa, IOSTAT = ios, ERR = 901) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namexa in reference namelist' ) + ! + REWIND( numnam_cfg ) ! Namelist namexa in configuration namelist : Example + READ ( numnam_cfg, namexa, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namexa in configuration namelist' ) + ! Output namelist for control + WRITE ( numond, namexa ) + ! + IF(lwp) THEN ! Control print + WRITE(numout,*) + WRITE(numout,*) 'exa_mpl_init : example ' + WRITE(numout,*) '~~~~~~~~~~~~' + WRITE(numout,*) ' Namelist namexa : set example parameters' + WRITE(numout,*) ' brief desciption exa_v1 = ', exa_v1 + WRITE(numout,*) ' brief desciption exa_v2 = ', exa_v2 + WRITE(numout,*) ' brief desciption nexa_0 = ', nexa_0 + WRITE(numout,*) ' brief desciption sn_ex%clname = ', sn_ex%clname + WRITE(numout,*) ' brief desciption sn_ex%nfreqh = ', sn_ex%nfreqh + ENDIF + ! + ! ! allocate exa_mpl arrays + IF( exa_mpl_alloc() /= 0 ) CALL ctl_stop( 'STOP', 'exa_mpl_init : unable to allocate arrays' ) + ! ! Parameter control + IF( ln_opt ) CALL ctl_stop( 'exa_mpl_init: this work and option xxx are incompatible' ) + IF( nn_opt == 2 ) CALL ctl_stop( 'STOP', 'exa_mpl_init: this work and option yyy may cause problems' ) + ! + END SUBROUTINE exa_mpl_init + +#else + !!---------------------------------------------------------------------- + !! Default option : NO example + !!---------------------------------------------------------------------- +CONTAINS + SUBROUTINE exa_mpl( kt, pvar1, pvar2, ptab ) ! Empty routine + REAL:: ptab(:,:) + WRITE(*,*) 'exa_mpl: You should not have seen this print! error?', kt, pvar1, pvar2, ptab(1,1) + END SUBROUTINE exa_mpl +#endif + + !!====================================================================== +END MODULE exampl diff --git a/NEMO_4.0.4_surge/src/OCE/nemo.f90 b/NEMO_4.0.4_surge/src/OCE/nemo.f90 new file mode 100644 index 0000000..041a9c6 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/nemo.f90 @@ -0,0 +1,21 @@ +PROGRAM nemo + !!====================================================================== + !! *** PROGRAM nemo *** + !! + !! ** Purpose : encapsulate nemo_gcm so that it can also be called + !! together with the linear tangent and adjoint models + !!====================================================================== + !! History : OPA ! 2001-02 (M. Imbard, A. Weaver) Original code + !! NEMO 1.0 ! 2003-10 (G. Madec) F90 + !!---------------------------------------------------------------------- + USE nemogcm ! NEMO system (nemo_gcm routine) + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- + ! + CALL nemo_gcm ! NEMO direct code + ! + !!====================================================================== +END PROGRAM nemo diff --git a/NEMO_4.0.4_surge/src/OCE/nemogcm.F90 b/NEMO_4.0.4_surge/src/OCE/nemogcm.F90 new file mode 100644 index 0000000..725c9a8 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/nemogcm.F90 @@ -0,0 +1,705 @@ +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 closea ! treatment of closed seas (for ln_closea) + USE usrdef_nam ! user defined configuration + USE tideini ! tidal components initialization (tide_ini routine) + USE bdy_oce, ONLY : ln_bdy + USE bdyini ! open boundary cond. setting (bdy_init routine) + USE istate ! initial state setting (istate_init routine) + USE ldfdyn ! lateral viscosity setting (ldfdyn_init routine) + USE ldftra ! lateral diffusivity setting (ldftra_init routine) + USE trdini ! dyn/tra trends initialization (trd_init routine) + USE asminc ! assimilation increments + USE asmbkg ! writing out state trajectory + USE diaptr ! poleward transports (dia_ptr_init routine) + USE diadct ! sections transports (dia_dct_init routine) + USE diaobs ! Observation diagnostics (dia_obs_init routine) + USE diacfl ! CFL diagnostics (dia_cfl_init routine) + USE diaharm ! tidal harmonics diagnostics (dia_harm_init routine) + USE step ! NEMO time-stepping (stp routine) + USE icbini ! handle bergs, initialisation + USE icbstp ! handle bergs, calving, themodynamics and transport + USE cpl_oasis3 ! OASIS3 coupling + USE c1d ! 1D configuration + USE step_c1d ! Time stepping loop for the 1D configuration + USE dyndmp ! Momentum damping + USE stopar ! Stochastic param.: ??? + USE stopts ! Stochastic param.: ??? + USE diurnal_bulk ! diurnal bulk SST + USE step_diu ! diurnal bulk SST timestepping (called from here if run offline) + USE crsini ! initialise grid coarsening utility + USE dia25h ! 25h mean output + USE sbc_oce , ONLY : lk_oasis + USE wet_dry ! Wetting and drying setting (wad_init routine) + USE dom_oce , ONLY : ln_2d +#if defined key_top + USE trcini ! passive tracer initialisation +#endif +#if defined key_nemocice_decomp + USE ice_domain_size, only: nx_global, ny_global +#endif + ! + USE in_out_manager ! I/O manager + USE lib_mpp ! distributed memory computing + USE mppini ! shared/distributed memory setting (mpp_init routine) + USE lbcnfd , ONLY : isendto, nsndto, nfsloop, nfeloop ! Setup of north fold exchanges + USE lib_fortran ! Fortran utilities (allows no signed zero when 'key_nosignedzero' defined) +#if defined key_iomput + USE xios ! xIOserver +#endif +#if defined key_agrif + USE agrif_all_update ! Master Agrif update +#endif + + 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 + +#if defined key_mpp_mpi + ! need MPI_Wtime + INCLUDE 'mpif.h' +#endif + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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 + !!---------------------------------------------------------------------- + ! +#if defined key_agrif + CALL Agrif_Init_Grids() ! AGRIF: set the meshes +#endif + ! !-----------------------! + CALL nemo_init !== Initialisations ==! + ! !-----------------------! +#if defined key_agrif + CALL Agrif_Declare_Var_dom ! AGRIF: set the meshes for DOM + CALL Agrif_Declare_Var ! " " " " " DYN/TRA +# if defined key_top + CALL Agrif_Declare_Var_top ! " " " " " TOP +# endif +# if defined key_si3 + CALL Agrif_Declare_Var_ice ! " " " " " Sea ice +# endif +#endif + ! 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 ==! + ! !-----------------------! + istp = nit000 + ! +#if defined key_c1d + DO WHILE ( istp <= nitend .AND. nstop == 0 ) !== C1D time-stepping ==! + CALL stp_c1d( istp ) + istp = istp + 1 + END DO +#else + ! +# if defined key_agrif + ! !== AGRIF time-stepping ==! + CALL Agrif_Regrid() + ! + ! Recursive update from highest nested level to lowest: + CALL Agrif_step_child_adj(Agrif_Update_All) + ! + DO WHILE( istp <= nitend .AND. nstop == 0 ) + CALL stp + istp = istp + 1 + END DO + ! +# else + ! + 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 ( 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 + ! +# endif + ! +#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 + ! +#if defined key_iomput + CALL xios_finalize ! end mpp communications with xios + IF( lk_oasis ) CALL cpl_finalize ! end coupling and mpp communications with OASIS +#else + IF ( lk_oasis ) THEN ; CALL cpl_finalize ! end coupling and mpp communications with OASIS + ELSEIF( lk_mpp ) THEN ; CALL mppstop ! end mpp communications + ENDIF +#endif + ! + 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/ ln_ctl , sn_cfctl, nn_print, nn_ictls, nn_ictle, & + & nn_isplt , nn_jsplt, nn_jctls, nn_jctle, & + & ln_timing, ln_diacfl + 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 defined key_iomput + 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 ) +#else + IF( lk_oasis ) THEN + IF( Agrif_Root() ) THEN + CALL cpl_init( "oceanx", ilocal_comm ) ! nemo local communicator given by oasis + ENDIF + CALL mpp_start( ilocal_comm ) + ELSE + CALL mpp_start( ) + ENDIF +#endif + ! + 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 ctl_opn( numnam_ref, 'namelist_ref', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + CALL ctl_opn( numnam_cfg, 'namelist_cfg', 'OLD', 'FORMATTED', 'SEQUENTIAL', -1, -1, .FALSE. ) + 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. ) +#ifdef key_agrif + ELSE + numnul = Agrif_Parent(numnul) +#endif + ENDIF + ! + ! !--------------------! + ! ! Open listing units ! -> need ln_ctl from namctl to define lwp + ! !--------------------! + ! + REWIND( numnam_ref ) ! Namelist namctl in reference namelist + READ ( numnam_ref, namctl, IOSTAT = ios, ERR = 901 ) +901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namctl in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namctl in confguration namelist + READ ( numnam_cfg, namctl, IOSTAT = ios, ERR = 902 ) +902 IF( ios > 0 ) CALL ctl_nam ( ios , 'namctl in configuration namelist' ) + ! + lwp = (narea == 1) .OR. ln_ctl ! 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 (2019) ' + 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 + ! + ENDIF + ! + ! finalize the definition of namctl variables + IF( sn_cfctl%l_config ) THEN + ! Activate finer control of report outputs + ! optionally switch off output from selected areas (note this only + ! applies to output which does not involve global communications) + 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., .FALSE. ) + ELSE + ! Use ln_ctl to turn on or off all options. + CALL nemo_set_cfctl( sn_cfctl, ln_ctl, .TRUE. ) + ENDIF + ! + IF(lwm) WRITE( numond, namctl ) + ! + ! !------------------------------------! + ! ! Set global domain size parameters ! + ! !------------------------------------! + ! + REWIND( numnam_ref ) ! Namelist namcfg in reference namelist + READ ( numnam_ref, namcfg, IOSTAT = ios, ERR = 903 ) +903 IF( ios /= 0 ) CALL ctl_nam ( ios , 'namcfg in reference namelist' ) + REWIND( numnam_cfg ) ! Namelist namcfg in confguration 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, jpiglo, jpjglo, jpkglo, jperio ) + ELSE ! user-defined namelist + CALL usr_def_nam( cn_cfg, nn_cfg, jpiglo, jpjglo, jpkglo, jperio ) + ENDIF + ! + IF(lwm) WRITE( numond, namcfg ) + ! + ! !-----------------------------------------! + ! ! mpp parameters and domain decomposition ! + ! !-----------------------------------------! + CALL mpp_init + + ! Now we know the dimensions of the grid and numout has been set: we can allocate arrays + CALL nemo_alloc() + + ! !-------------------------------! + ! ! NEMO general initialization ! + ! !-------------------------------! + + CALL nemo_ctl ! Control prints + ! + ! ! 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 + IF( lk_c1d ) CALL c1d_init ! 1D column configuration + CALL wad_init ! Wetting and drying options + CALL dom_init("OPA") ! Domain + IF( ln_crs ) CALL crs_init ! coarsened grid: domain initialization + IF( ln_ctl ) 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 ! ocean initial state (Dynamics and tracers) + CALL sbc_init ! Forcings : surface module + CALL tra_qsr_init ! penetrative solar radiation qsr + IF( ln_diaobs ) THEN ! Observation & model comparison + CALL dia_obs_init ! Initialize observational data + CALL dia_obs( nit000 - 1 ) ! Observation operator for restart + ENDIF + IF( lk_asminc ) CALL asm_inc_init ! Assimilation increments + ! + RETURN ! end of initialization + ENDIF + + CALL istate_init ! ocean initial state (Dynamics and tracers) + + ! ! external forcing + CALL tide_init ! tidal harmonics + CALL sbc_init ! surface boundary conditions (including sea-ice) + CALL bdy_init ! Open boundaries initialisation + + ! ! Ocean physics + CALL zdf_phy_init ! Vertical physics + + ! ! Lateral physics + IF (.NOT. ln_2d) CALL ldf_tra_init ! Lateral ocean tracer physics + CALL ldf_eiv_init ! eddy induced velocity param. + CALL ldf_dyn_init ! Lateral ocean momentum physics + + ! ! Active tracers + IF (.NOT. ln_2d) THEN ! No tracers in 2D mode + 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 + ENDIF + + ! ! Dynamics + IF( lk_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 ! horizontal gradient of Hydrostatic pressure + CALL dyn_spg_init ! surface pressure gradient + +#if defined key_top + ! ! Passive tracers + CALL trc_init +#endif + IF( l_ldfslp ) CALL ldf_slp_init ! slope of lateral mixing + + ! ! Icebergs + CALL icb_init( rdt, nit000) ! initialise icebergs instance + + ! ! Misc. options + CALL sto_par_init ! Stochastic parametrization + IF( ln_sto_eos ) CALL sto_pts_init ! RRandom T/S fluctuations + + ! ! Diagnostics + CALL flo_init ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl_init ! Initialise CFL diagnostics + CALL dia_ptr_init ! Poleward TRansports initialization + CALL dia_dct_init ! Sections tranports + CALL dia_hsb_init ! heat content, salt content and volume budgets + CALL trd_init ! Mixed-layer/Vorticity/Integral constraints trends + CALL dia_obs_init ! Initialize observational data + CALL dia_25h_init ! 25h mean outputs + CALL dia_harm_init ! tidal harmonics outputs + IF( ln_diaobs ) CALL dia_obs( nit000-1 ) ! Observation operator for restart + + ! ! Assimilation increments + IF( lk_asminc ) CALL asm_inc_init ! 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,*) ' run control (for debugging) ln_ctl = ', ln_ctl + WRITE(numout,*) ' finer control over o/p sn_cfctl%l_config = ', sn_cfctl%l_config + 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_mppout = ', sn_cfctl%l_mppout + WRITE(numout,*) ' sn_cfctl%l_mpptop = ', sn_cfctl%l_mpptop + 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,*) ' level of print nn_print = ', nn_print + 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 + WRITE(numout,*) ' number of proc. following i nn_isplt = ', nn_isplt + WRITE(numout,*) ' number of proc. following j nn_jsplt = ', nn_jsplt + WRITE(numout,*) ' timing by routine ln_timing = ', ln_timing + WRITE(numout,*) ' CFL diagnostics ln_diacfl = ', ln_diacfl + ENDIF + ! + nprint = nn_print ! convert DOCTOR namelist names into OLD names + nictls = nn_ictls + nictle = nn_ictle + njctls = nn_jctls + njctle = nn_jctle + isplt = nn_isplt + jsplt = nn_jsplt + + 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( .NOT.ln_read_cfg ) ln_closea = .false. ! dealing possible only with a domcfg file + ! + ! ! Parameter control + ! + IF( ln_ctl ) THEN ! sub-domain area indices for the control prints + IF( lk_mpp .AND. jpnij > 1 ) THEN + isplt = jpni ; jsplt = jpnj ; ijsplt = jpni*jpnj ! the domain is forced to the real split domain + ELSE + IF( isplt == 1 .AND. jsplt == 1 ) THEN + CALL ctl_warn( ' - isplt & jsplt are equal to 1', & + & ' - the print control will be done over the whole domain' ) + ENDIF + ijsplt = isplt * jsplt ! total number of processors ijsplt + ENDIF + IF(lwp) WRITE(numout,*)' - The total number of processors over which the' + IF(lwp) WRITE(numout,*)' print control will be done is ijsplt : ', ijsplt + ! + ! ! indices used for the SUM control + IF( nictls+nictle+njctls+njctle == 0 ) THEN ! print control done over the default area + lsp_area = .FALSE. + ELSE ! print control done over a specific area + lsp_area = .TRUE. + IF( nictls < 1 .OR. nictls > jpiglo ) THEN + CALL ctl_warn( ' - nictls must be 1<=nictls>=jpiglo, it is forced to 1' ) + nictls = 1 + ENDIF + IF( nictle < 1 .OR. nictle > jpiglo ) THEN + CALL ctl_warn( ' - nictle must be 1<=nictle>=jpiglo, it is forced to jpiglo' ) + nictle = jpiglo + ENDIF + IF( njctls < 1 .OR. njctls > jpjglo ) THEN + CALL ctl_warn( ' - njctls must be 1<=njctls>=jpjglo, it is forced to 1' ) + njctls = 1 + ENDIF + IF( njctle < 1 .OR. njctle > jpjglo ) THEN + CALL ctl_warn( ' - njctle must be 1<=njctle>=jpjglo, it is forced to jpjglo' ) + njctle = jpjglo + ENDIF + ENDIF + 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' ) + ! +#if defined key_agrif + IF( ln_timing ) CALL ctl_stop( 'AGRIF not implemented with ln_timing = true') +#endif + ! + 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( numnam_ref /= -1 ) CLOSE( numnam_ref ) ! oce reference namelist + IF( numnam_cfg /= -1 ) CLOSE( numnam_cfg ) ! oce configuration namelist + IF( lwm.AND.numond /= -1 ) CLOSE( numond ) ! oce output namelist + IF( numnam_ice_ref /= -1 ) CLOSE( numnam_ice_ref ) ! ice reference namelist + IF( numnam_ice_cfg /= -1 ) CLOSE( numnam_ice_cfg ) ! ice configuration 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 OPA 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, for_all ) + !!---------------------------------------------------------------------- + !! *** ROUTINE nemo_set_cfctl *** + !! + !! ** Purpose : Set elements of the output control structure to setto. + !! for_all should be .false. unless all areas are to be + !! treated identically. + !! + !! ** Method : Note this routine can be used to switch on/off some + !! types of output for selected areas but any output types + !! that involve global communications (e.g. mpp_max, glob_sum) + !! should be protected from selective switching by the + !! for_all argument + !!---------------------------------------------------------------------- + LOGICAL :: setto, for_all + TYPE(sn_ctl) :: sn_cfctl + !!---------------------------------------------------------------------- + IF( for_all ) THEN + sn_cfctl%l_runstat = setto + sn_cfctl%l_trcstat = setto + ENDIF + sn_cfctl%l_oceout = setto + sn_cfctl%l_layout = setto + sn_cfctl%l_mppout = setto + sn_cfctl%l_mpptop = setto + END SUBROUTINE nemo_set_cfctl + + !!====================================================================== +END MODULE nemogcm + diff --git a/NEMO_4.0.4_surge/src/OCE/oce.F90 b/NEMO_4.0.4_surge/src/OCE/oce.F90 new file mode 100644 index 0000000..5d2c839 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/oce.F90 @@ -0,0 +1,122 @@ +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 + !!---------------------------------------------------------------------- + USE par_oce ! ocean parameters + USE lib_mpp ! MPP library + + IMPLICIT NONE + PRIVATE + + PUBLIC oce_alloc ! routine called by nemo_init in nemogcm.F90 + + !! dynamics and tracer fields ! before ! now ! after ! the after trends becomes the fields + !! -------------------------- ! fields ! fields ! trends ! only after tra_zdf and dyn_spg + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: ub , un , ua !: i-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: vb , vn , va !: j-horizontal velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wn !: vertical velocity [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: wi !: vertical vel. (adaptive-implicit) [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: hdivn !: horizontal divergence [s-1] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:,:) :: tsb , tsn , tsa !: 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-rau0)/rau0 [no units] + REAL(wp), 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 ! before ! now ! after ! + !! ------------ ! fields ! fields ! fields ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: ub_b , un_b , ua_b !: Barotropic velocities at u-point [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: vb_b , vn_b , va_b !: Barotropic velocities at v-point [m/s] + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: sshb , sshn , ssha !: sea surface height at t-point [m] + + !! 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, 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 + ! + REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:) :: spgu, spgv !: horizontal surface pressure gradient + + !! 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 [-] + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + INTEGER FUNCTION oce_alloc() + !!---------------------------------------------------------------------- + !! *** FUNCTION oce_alloc *** + !!---------------------------------------------------------------------- + INTEGER :: ierr(6) + !!---------------------------------------------------------------------- + ! + ierr(:) = 0 + ALLOCATE( ub (jpi,jpj,jpk) , un (jpi,jpj,jpk) , ua(jpi,jpj,jpk) , & + & vb (jpi,jpj,jpk) , vn (jpi,jpj,jpk) , va(jpi,jpj,jpk) , & + & wn (jpi,jpj,jpk) , hdivn(jpi,jpj,jpk) , & + & tsb (jpi,jpj,jpk,jpts) , tsn (jpi,jpj,jpk,jpts) , tsa(jpi,jpj,jpk,jpts) , & + & 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( sshb(jpi,jpj) , sshn(jpi,jpj) , ssha(jpi,jpj) , & + & ub_b(jpi,jpj) , un_b(jpi,jpj) , ua_b(jpi,jpj) , & + & vb_b(jpi,jpj) , vn_b(jpi,jpj) , va_b(jpi,jpj) , & + & spgu (jpi,jpj) , spgv(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(6) ) +#if defined key_agrif + ALLOCATE( ub2_i_b(jpi,jpj), vb2_i_b(jpi,jpj) , STAT=ierr(6) ) +#endif + ! + oce_alloc = MAXVAL( ierr ) + IF( oce_alloc /= 0 ) CALL ctl_stop( 'STOP', 'oce_alloc: failed to allocate arrays' ) + ! + END FUNCTION oce_alloc + + !!====================================================================== +END MODULE oce diff --git a/NEMO_4.0.4_surge/src/OCE/par_kind.F90 b/NEMO_4.0.4_surge/src/OCE/par_kind.F90 new file mode 100644 index 0000000..b5e9523 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/par_kind.F90 @@ -0,0 +1,40 @@ +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 + + INTEGER, PUBLIC, PARAMETER :: jpbyt = 8 !: real size for mpp communications + INTEGER, PUBLIC, PARAMETER :: jpbytda = 4 !: real size in input data files 4 or 8 + + ! 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 = dp !: 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 + + !!---------------------------------------------------------------------- + !! NEMO 3.3 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +END MODULE par_kind diff --git a/NEMO_4.0.4_surge/src/OCE/par_oce.F90 b/NEMO_4.0.4_surge/src/OCE/par_oce.F90 new file mode 100644 index 0000000..a2d8b46 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/par_oce.F90 @@ -0,0 +1,83 @@ +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. + ! + + !!--------------------------------------------------------------------- + !! 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 + + ! 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 = 3 !: number of ghost cells + INTEGER, PUBLIC :: nbcellsx ! = jpiglo - 2 - 2*nbghostcells !: number of cells in i-direction + INTEGER, PUBLIC :: nbcellsy ! = jpjglo - 2 - 2*nbghostcells !: 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 :: jpim1 ! = jpi-1 !: inner domain indices + INTEGER, PUBLIC :: jpjm1 ! = jpj-1 !: - - - + INTEGER, PUBLIC :: jpkm1 ! = jpk-1 !: - - - + INTEGER, PUBLIC :: jpij ! = jpi*jpj !: jpi x jpj + INTEGER, PUBLIC :: jpimax! = ( jpiglo-2*nn_hls + (jpni-1) ) / jpni + 2*nn_hls !: maximum jpi + INTEGER, PUBLIC :: jpjmax! = ( jpjglo-2*nn_hls + (jpnj-1) ) / jpnj + 2*nn_hls !: maximum jpj + + !!--------------------------------------------------------------------- + !! 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 + INTEGER, PUBLIC, PARAMETER :: nn_hls = 1 !: halo width (applies to both rows and columns) + + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE par_oce diff --git a/MY_SRC/step.F90 b/NEMO_4.0.4_surge/src/OCE/step.F90 similarity index 70% rename from MY_SRC/step.F90 rename to NEMO_4.0.4_surge/src/OCE/step.F90 index fe08ea3..d31bc6d 100644 --- a/MY_SRC/step.F90 +++ b/NEMO_4.0.4_surge/src/OCE/step.F90 @@ -28,7 +28,8 @@ MODULE step !! 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 + !! - ! 2015-11 (J. Chanut) free surface simplification (remove filtered free surface) + !! 4.0 ! 2017-05 (G. Madec) introduction of the vertical physics manager (zdfphy) !!---------------------------------------------------------------------- !!---------------------------------------------------------------------- @@ -44,9 +45,9 @@ MODULE step PUBLIC stp ! called by nemogcm.F90 !!---------------------------------------------------------------------- - !! NEMO/OPA 3.7 , NEMO Consortium (2015) - !! $Id: step.F90 7753 2017-03-03 11:46:59Z mocavero $ - !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) !!---------------------------------------------------------------------- CONTAINS @@ -60,9 +61,9 @@ SUBROUTINE stp( kstp ) !!---------------------------------------------------------------------- !! *** ROUTINE stp *** !! - !! ** Purpose : - Time stepping of OPA (momentum and active tracer eqs.) - !! - Time stepping of LIM (dynamic and thermodynamic eqs.) - !! - Tme stepping of TRC (passive tracer eqs.) + !! ** Purpose : - Time stepping of OPA (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 @@ -73,11 +74,12 @@ SUBROUTINE stp( kstp ) !! -7- Compute the diagnostics variables (rd,N2, hdiv,w) !! -8- Outputs and diagnostics !!---------------------------------------------------------------------- - INTEGER :: ji,jj,jk ! dummy loop indice - INTEGER :: indic ! error indicator if < 0 - INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt) + INTEGER :: ji, jj, jk ! dummy loop indice +!!gm kcall can be removed, I guess + INTEGER :: kcall ! optional integer argument (dom_vvl_sf_nxt) !! --------------------------------------------------------------------- #if defined key_agrif + IF( nstop > 0 ) RETURN ! avoid to go further if an error was detected during previous time step (child grid) kstp = nit000 + Agrif_Nb_Step() IF( lk_agrif_debug ) THEN IF( Agrif_Root() .and. lwp) WRITE(*,*) '---' @@ -88,11 +90,12 @@ SUBROUTINE stp( kstp ) IF( Agrif_Nbstepint() == 0 ) CALL iom_swap( cxios_context ) # endif #endif + ! + IF( ln_timing ) CALL timing_start('stp') + ! !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! update I/O and calendar !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - indic = 0 ! reset to no error condition - IF( kstp == nit000 ) THEN ! initialize IOM context (must be done after nemo_init for AGRIF+XIOS+OASIS) CALL iom_init( cxios_context ) ! for model grid (including passible AGRIF zoom) IF( ln_crs ) CALL iom_init( TRIM(cxios_context)//"_crs" ) ! for coarse grid @@ -106,7 +109,7 @@ SUBROUTINE stp( kstp ) !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< IF( ln_tide ) CALL sbc_tide( 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, time_offset=+1 ) ! update dynamic & tracer data at open boundaries + IF( ln_bdy ) CALL bdy_dta ( kstp, kt_offset = +1 ) ! update dynamic & tracer data at open boundaries CALL sbc ( kstp ) ! Sea Boundary Condition (including sea-ice) !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @@ -116,44 +119,19 @@ SUBROUTINE stp( kstp ) IF( ln_sto_eos ) CALL sto_pts( tsn ) ! Random T/S fluctuations !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - ! Ocean physics update (ua, va, tsa used as workspace) + ! Ocean physics update !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! THERMODYNAMICS + IF ( .NOT. ln_2d ) THEN CALL eos_rab( tsb, rab_b ) ! before local thermal/haline expension ratio at T-points CALL eos_rab( tsn, rab_n ) ! now local thermal/haline expension ratio at T-points CALL bn2 ( tsb, rab_b, rn2b ) ! before Brunt-Vaisala frequency CALL bn2 ( tsn, rab_n, rn2 ) ! now Brunt-Vaisala frequency - - ! - ! VERTICAL PHYSICS - CALL zdf_bfr( kstp ) ! bottom friction (if quadratic) - ! ! Vertical eddy viscosity and diffusivity coefficients - IF( lk_zdfric ) CALL zdf_ric ( kstp ) ! Richardson number dependent Kz - IF( lk_zdftke ) CALL zdf_tke ( kstp ) ! TKE closure scheme for Kz - IF( lk_zdfgls ) CALL zdf_gls ( kstp ) ! GLS closure scheme for Kz - IF( ln_zdfqiao ) CALL zdf_qiao( kstp ) ! Qiao vertical mixing - ! - IF( lk_zdfcst ) THEN ! Constant Kz (reset avt, avm[uv] to the background value) - avt (:,:,:) = rn_avt0 * wmask (:,:,:) - avmu(:,:,:) = rn_avm0 * wumask(:,:,:) - avmv(:,:,:) = rn_avm0 * wvmask(:,:,:) - ENDIF - - IF( ln_rnf_mouth ) THEN ! increase diffusivity at rivers mouths - DO jk = 2, nkrnf ; avt(:,:,jk) = avt(:,:,jk) + 2._wp * rn_avt_rnf * rnfmsk(:,:) * tmask(:,:,jk) ; END DO ENDIF - IF( ln_zdfevd ) CALL zdf_evd( kstp ) ! enhanced vertical eddy diffusivity - - IF( lk_zdftmx ) CALL zdf_tmx( kstp ) ! tidal vertical mixing - - IF( lk_zdfddm ) CALL zdf_ddm( kstp ) ! double diffusive mixing - - CALL zdf_mxl( kstp ) ! mixed layer depth + + ! VERTICAL PHYSICS + CALL zdf_phy( kstp ) ! vertical physics update (top/bot drag, avt, avs, avm + MLD) - ! write TKE or GLS information in the restart file - IF( lrst_oce .AND. lk_zdftke ) CALL tke_rst( kstp, 'WRITE' ) - IF( lrst_oce .AND. lk_zdfgls ) CALL gls_rst( kstp, 'WRITE' ) - ! ! LATERAL PHYSICS ! IF( l_ldfslp ) THEN ! slope of lateral mixing @@ -175,27 +153,16 @@ SUBROUTINE stp( kstp ) ! ! eddy diffusivity coeff. IF( l_ldftra_time .OR. l_ldfeiv_time ) CALL ldf_tra( kstp ) ! and/or eiv coeff. IF( l_ldfdyn_time ) CALL ldf_dyn( kstp ) ! eddy viscosity coeff. - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! Ocean dynamics : hdiv, ssh, e3, u, v, w !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< CALL ssh_nxt ( kstp ) ! after ssh (includes call to div_hor) - IF(.NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors + IF( .NOT.ln_linssh ) CALL dom_vvl_sf_nxt( kstp ) ! after vertical scale factors CALL wzv ( kstp ) ! now cross-level velocity - CALL eos ( tsn, rhd, rhop, gdept_n(:,:,:) ) ! now in situ density for hpg computation + IF( ln_zad_Aimp ) CALL wAimp ( kstp ) ! Adaptive-implicit vertical advection partitioning + IF( .NOT. ln_2d ) CALL eos ( tsn, rhd, rhop, gdept_n(:,:,:) ) ! now in situ density for hpg computation -!!jc: fs simplification -!!jc: lines below are useless if ln_linssh=F. Keep them here (which maintains a bug if ln_linssh=T and ln_zps=T, cf ticket #1636) -!! but ensures reproductible results -!! with previous versions using split-explicit free surface - IF( ln_zps .AND. .NOT. ln_isfcav ) & - & CALL zps_hde ( kstp, jpts, tsn, 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, jpts, tsn, gtsu, gtsv, gtui, gtvi, & ! Partial steps for top cell (ISF) - & rhd, gru , grv , grui, grvi ) ! of t, s, rd at the first ocean level -!!jc: fs simplification ua(:,:,:) = 0._wp ! set dynamics trends to zero va(:,:,:) = 0._wp @@ -210,6 +177,7 @@ SUBROUTINE stp( kstp ) CALL dyn_adv ( kstp ) ! advection (vector or flux form) CALL dyn_vor ( kstp ) ! vorticity term including Coriolis CALL dyn_ldf ( kstp ) ! lateral mixing + IF( ln_zdfosm ) CALL dyn_osm ( kstp ) ! OSMOSIS non-local velocity fluxes CALL dyn_hpg ( kstp ) ! horizontal gradient of Hydrostatic pressure CALL dyn_spg ( kstp ) ! surface pressure gradient @@ -217,11 +185,13 @@ SUBROUTINE stp( kstp ) IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated CALL div_hor ( kstp ) ! Horizontal divergence (2nd call in time-split case) IF(.NOT.ln_linssh) CALL dom_vvl_sf_nxt( kstp, kcall=2 ) ! after vertical scale factors (update depth average component) + ENDIF + IF( .NOT. ln_2d ) CALL dyn_zdf ( kstp ) ! vertical diffusion + IF( ln_dynspg_ts ) THEN ! vertical scale factors and vertical velocity need to be updated CALL wzv ( kstp ) ! now cross-level velocity + IF( ln_zad_Aimp ) CALL wAimp ( kstp ) ! Adaptive-implicit vertical advection partitioning ENDIF - CALL dyn_bfr ( kstp ) ! bottom friction - CALL dyn_zdf ( kstp ) ! vertical diffusion !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! cool skin @@ -229,19 +199,17 @@ SUBROUTINE stp( kstp ) IF ( ln_diurnal ) CALL stp_diurnal( kstp ) !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - ! diagnostics and outputs (ua, va, tsa used as workspace) + ! diagnostics and outputs !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - IF( lk_floats ) CALL flo_stp( kstp ) ! drifting Floats - IF( nn_diacfl == 1 ) CALL dia_cfl( kstp ) ! Courant number diagnostics - IF( lk_diahth ) CALL dia_hth( kstp ) ! Thermocline depth (20 degres isotherm depth) - IF( lk_diadct ) CALL dia_dct( kstp ) ! Transports - CALL dia_ar5( kstp ) ! ar5 diag - IF( lk_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis - ! NB - new harmonic analysis - IF( lk_diaharm_fast ) & - & CALL dia_harm_fast( kstp ) ! Tidal harmonic analysis - restart and faster version - ! END NB - CALL dia_wri( kstp ) ! ocean model: outputs + IF( ln_floats ) CALL flo_stp ( kstp ) ! drifting Floats + IF( ln_diacfl ) CALL dia_cfl ( kstp ) ! Courant number diagnostics + CALL dia_hth ( kstp ) ! Thermocline depth (20 degres isotherm depth) + IF( ln_diadct ) CALL dia_dct ( kstp ) ! Transports + CALL dia_ar5 ( kstp ) ! ar5 diag + IF( ln_diaptr ) CALL dia_ptr ! Poleward adv/ldf TRansports diagnostics + IF( ln_diaharm ) CALL dia_harm( kstp ) ! Tidal harmonic analysis + CALL dia_prod( kstp ) ! ocean model: product diagnostics + CALL dia_wri ( kstp ) ! ocean model: outputs ! IF( ln_crs ) CALL crs_fld ( kstp ) ! ocean model: online field coarsening & output @@ -255,6 +223,7 @@ SUBROUTINE stp( kstp ) !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! Active tracers !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF (.NOT. ln_2d) THEN ! No tracers in 2D mode tsa(:,:,:,:) = 0._wp ! set tracer trends to zero IF( lk_asminc .AND. ln_asmiau .AND. & @@ -262,7 +231,7 @@ SUBROUTINE stp( kstp ) CALL tra_sbc ( kstp ) ! surface boundary condition IF( ln_traqsr ) CALL tra_qsr ( kstp ) ! penetrative solar radiation qsr IF( ln_trabbc ) CALL tra_bbc ( kstp ) ! bottom heat flux - IF( lk_trabbl ) CALL tra_bbl ( kstp ) ! advective (and/or diffusive) bottom boundary layer scheme + IF( ln_trabbl ) CALL tra_bbl ( kstp ) ! advective (and/or diffusive) bottom boundary layer scheme IF( ln_tradmp ) CALL tra_dmp ( kstp ) ! internal damping trends IF( ln_bdy ) CALL bdy_tra_dmp ( kstp ) ! bdy damping trends #if defined key_agrif @@ -270,14 +239,15 @@ SUBROUTINE stp( kstp ) & CALL Agrif_Sponge_tra ! tracers sponge #endif CALL tra_adv ( kstp ) ! horizontal & vertical advection + IF( ln_zdfosm ) CALL tra_osm ( kstp ) ! OSMOSIS non-local tracer fluxes + IF( lrst_oce .AND. ln_zdfosm ) & + & CALL osm_rst( kstp, 'WRITE' )! write OSMOSIS outputs + wn (so must do here) to restarts CALL tra_ldf ( kstp ) ! lateral mixing -!!gm : why CALL to dia_ptr has been moved here??? (use trends info?) - IF( ln_diaptr ) CALL dia_ptr ! Poleward adv/ldf TRansports diagnostics -!!gm CALL tra_zdf ( kstp ) ! vertical mixing and after tracer fields IF( ln_zdfnpc ) CALL tra_npc ( kstp ) ! update after fields by non-penetrative convection - + ENDIF ! not ln_2d + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! Set boundary conditions and Swap !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -295,70 +265,72 @@ SUBROUTINE stp( kstp ) !! place. !! !!jc2: dynnxt must be the latest call. e3t_b are indeed updated in that routine - CALL tra_nxt ( kstp ) ! finalize (bcs) tracer fields at next time step and swap - CALL dyn_nxt ( kstp ) ! finalize (bcs) velocities at next time step and swap + IF (.NOT. ln_2d) CALL tra_nxt ( kstp ) ! finalize (bcs) tracer fields at next time step and swap + CALL dyn_nxt ( kstp ) ! finalize (bcs) velocities at next time step and swap (always called after tra_nxt) CALL ssh_swp ( kstp ) ! swap of sea surface height IF(.NOT.ln_linssh) CALL dom_vvl_sf_swp( kstp ) ! swap of vertical scale factors ! - IF( ln_diahsb ) CALL dia_hsb( kstp ) ! - ML - global conservation diagnostics + IF( ln_diahsb ) CALL dia_hsb ( kstp ) ! - 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 ) ! write output ocean restart file - IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters + IF( lrst_oce ) CALL rst_write ( kstp ) ! write output ocean restart file + IF( ln_sto_eos ) CALL sto_rst_write( kstp ) ! write restart file for stochastic parameters #if defined key_agrif !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - ! AGRIF + ! AGRIF recursive integration !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - CALL Agrif_Integrate_ChildGrids( stp ) - - IF( Agrif_NbStepint() == 0 ) THEN ! AGRIF Update -!!jc in fact update is useless at last time step, but do it for global diagnostics - CALL Agrif_Update_Tra() ! Update active tracers - CALL Agrif_Update_Dyn() ! Update momentum - ENDIF + CALL Agrif_Integrate_ChildGrids( stp ) ! allows to finish all the Child Grids before updating #endif - IF( ln_diaobs ) CALL dia_obs( kstp ) ! obs-minus-model (assimilation) diagnostics (call after dynamics update) - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! Control !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - CALL stp_ctl ( kstp, indic ) - IF( indic < 0 ) THEN - CALL ctl_stop( 'step: indic < 0' ) - CALL dia_wri_state( 'output.abort', kstp ) + CALL stp_ctl ( kstp ) + +#if defined key_agrif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! AGRIF update + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + IF( Agrif_NbStepint() == 0 .AND. nstop == 0 ) THEN + CALL Agrif_update_all( ) ! Update all components ENDIF -!#if defined key_harm_ana -!--- NB Restart for the tidal harmonic analysis -! IF( ln_harm_ana_store ) CALL harm_ana( kstp ) ! Harmonic analysis of tides -!--- END NB ----------------------------------- -!# endif - IF( kstp == nit000 ) THEN - CALL iom_close( numror ) ! close input ocean restart file - IF(lwm) CALL FLUSH ( numond ) ! flush output namelist oce - IF(lwm.AND.numoni /= -1 ) & - & CALL FLUSH ( numoni ) ! flush output namelist ice (if exist) +#endif + + IF( ln_diaobs ) CALL dia_obs ( kstp ) ! obs-minus-model (assimilation) diagnostics (call 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(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 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< !!gm why lk_oasis and not lk_cpl ???? - IF( lk_oasis ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges + IF( lk_oasis .AND. nstop == 0 ) CALL sbc_cpl_snd( kstp ) ! coupled mode : field exchanges ! #if defined key_iomput - IF( kstp == nitend .OR. indic < 0 ) THEN - CALL iom_context_finalize( cxios_context ) ! needed for XIOS+AGRIF + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! 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( lrxios ) CALL iom_context_finalize( crxios_context ) IF( ln_crs ) CALL iom_context_finalize( trim(cxios_context)//"_crs" ) ! ENDIF #endif ! - IF( nn_timing == 1 .AND. kstp == nit000 ) CALL timing_reset + IF( ln_timing ) CALL timing_stop('stp') ! END SUBROUTINE stp - + ! + !!====================================================================== END MODULE step diff --git a/NEMO_4.0.4_surge/src/OCE/step_oce.F90 b/NEMO_4.0.4_surge/src/OCE/step_oce.F90 new file mode 100644 index 0000000..af6dccf --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/step_oce.F90 @@ -0,0 +1,117 @@ +MODULE step_oce + !!====================================================================== + !! *** MODULE step_oce *** + !! Ocean time-stepping : module used in both initialisation phase and time stepping + !!====================================================================== + !! 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 zdf_oce ! ocean vertical physics variables + USE zdfdrg , ONLY : ln_drgimp ! implicit top/bottom friction + + 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 sbctide ! Tide initialisation + USE sbcwave ! Wave intialisation + + USE traqsr ! solar radiation penetration (tra_qsr 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 tranxt ! time-stepping (tra_nxt routine) + USE tranpc ! non-penetrative convection (tra_npc routine) + + USE eosbn2 ! equation of state (eos_bn2 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 dynnxt ! time-stepping (dyn_nxt routine) + + USE stopar ! Stochastic parametrization (sto_par routine) + USE stopts + + 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 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 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 zdfphy ! vertical physics manager (zdf_phy_init routine) + USE zdfosm , ONLY : osm_rst, dyn_osm, tra_osm ! OSMOSIS routines used in step.F90 + + USE step_diu ! Time stepping for diurnal sst + USE diurnal_bulk ! diurnal SST bulk routines (diurnal_sst_takaya routine) + USE cool_skin ! diurnal cool skin correction (diurnal_sst_coolskin routine) + 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 diaharm + USE diaprod + USE diacfl + USE diaobs ! Observation operator + 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 + 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 + +#if defined key_iomput + USE xios ! I/O server +#endif +#if defined key_agrif + USE agrif_oce_sponge ! Momemtum and tracers sponges + USE agrif_all_update ! Main update driver +#endif +#if defined key_top + USE trcstp ! passive tracer time-stepping (trc_stp routine) +#endif + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!====================================================================== +END MODULE step_oce diff --git a/NEMO_4.0.4_surge/src/OCE/stpctl.F90 b/NEMO_4.0.4_surge/src/OCE/stpctl.F90 new file mode 100644 index 0000000..a1f31c2 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/stpctl.F90 @@ -0,0 +1,290 @@ +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 c1d ! 1D vertical configuration + 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 zdf_oce , ONLY : ln_zad_Aimp ! ocean vertical physics variables + USE wet_dry, ONLY : ll_wd, ssh_ref ! reference depth for negative bathy + + USE netcdf ! NetCDF library + IMPLICIT NONE + PRIVATE + + PUBLIC stp_ctl ! routine called by step.F90 + + INTEGER :: idrun, idtime, idssh, idu, ids1, ids2, idt1, idt2, idc1, idw1, istatus + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +CONTAINS + + SUBROUTINE stp_ctl( kt ) + !!---------------------------------------------------------------------- + !! *** ROUTINE stp_ctl *** + !! + !! ** Purpose : Control the run + !! + !! ** Method : - Save the time step in numstp + !! - Print it each 50 time steps + !! - 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 :: ji, jj, jk ! dummy loop indices + INTEGER, DIMENSION(3) :: ih, iu, is1, is2 ! min/max loc indices + INTEGER, DIMENSION(9) :: iareasum, iareamin, iareamax + REAL(wp) :: zzz ! local real + REAL(wp), DIMENSION(9) :: zmax, zmaxlocal + LOGICAL :: ll_wrtstp, ll_colruns, ll_wrtruns + 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 = ll_wrtstp .AND. sn_cfctl%l_runstat .AND. jpnij > 1 + ll_wrtruns = ( ll_colruns .OR. jpnij == 1 ) .AND. lwm + ! + IF( kt == nit000 ) THEN + ! + IF( lwp ) THEN + WRITE(numout,*) + WRITE(numout,*) 'stp_ctl : time-stepping control' + WRITE(numout,*) '~~~~~~~' + ENDIF + ! ! open time.step file + IF( lwm ) CALL ctl_opn( numstp, 'time.step', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + ! ! open run.stat file(s) at start whatever + ! ! the value of sn_cfctl%ptimincr + IF( ll_wrtruns ) THEN + CALL ctl_opn( numrun, 'run.stat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, lwp, narea ) + clname = 'run.stat.nc' + IF( .NOT. Agrif_Root() ) clname = TRIM(Agrif_CFixed())//"_"//TRIM(clname) + istatus = NF90_CREATE( TRIM(clname), NF90_CLOBBER, idrun ) + istatus = NF90_DEF_DIM( idrun, 'time', NF90_UNLIMITED, idtime ) + istatus = NF90_DEF_VAR( idrun, 'abs_ssh_max', NF90_DOUBLE, (/ idtime /), idssh ) + istatus = NF90_DEF_VAR( idrun, 'abs_u_max', NF90_DOUBLE, (/ idtime /), idu ) + istatus = NF90_DEF_VAR( idrun, 's_min', NF90_DOUBLE, (/ idtime /), ids1 ) + istatus = NF90_DEF_VAR( idrun, 's_max', NF90_DOUBLE, (/ idtime /), ids2 ) + istatus = NF90_DEF_VAR( idrun, 't_min', NF90_DOUBLE, (/ idtime /), idt1 ) + istatus = NF90_DEF_VAR( idrun, 't_max', NF90_DOUBLE, (/ idtime /), idt2 ) + IF( ln_zad_Aimp ) THEN + istatus = NF90_DEF_VAR( idrun, 'abs_wi_max', NF90_DOUBLE, (/ idtime /), idw1 ) + istatus = NF90_DEF_VAR( idrun, 'Cf_max', NF90_DOUBLE, (/ idtime /), idc1 ) + ENDIF + istatus = NF90_ENDDEF(idrun) + ENDIF + ENDIF + ! + IF(lwm .AND. ll_wrtstp) THEN !== current time step ==! ("time.step" file) + WRITE ( numstp, '(1x, i8)' ) kt + REWIND( numstp ) + ENDIF + ! + ! !== test of extrema ==! + ! + ! define zmax default value. needed for land processors + IF( ll_colruns ) THEN ! default value: must not be kept when calling mpp_max -> must be as small as possible + zmax(:) = -HUGE(1._wp) + ELSE ! default value: must not give true for any of the tests bellow (-> avoid manipulating HUGE...) + zmax(:) = 0._wp + zmax(3) = -1._wp ! avoid salinity minimum at 0. + ENDIF + ! + IF( ll_wd ) THEN + zmax(1) = MAXVAL( ABS( sshn(:,:) + ssh_ref*tmask(:,:,1) ) ) ! ssh max + ELSE + zmax(1) = MAXVAL( ABS( sshn(:,:) ) ) ! ssh max + ENDIF + zmax(2) = MAXVAL( ABS( un(:,:,:) ) ) ! velocity max (zonal only) + llmsk(:,:,:) = tmask(:,:,:) == 1._wp + IF( COUNT( llmsk(:,:,:) ) > 0 ) THEN ! avoid huge values sent back for land processors... + zmax(4) = MAXVAL( tsn(:,:,:,jp_sal)*tmask ) ! salinity max + zmax(3) = MAXVAL( (zmax(4)-tsn(:,:,:,jp_sal))*tmask ) - zmax(4) ! minus salinity max + IF( ll_colruns .OR. jpnij == 1 ) THEN ! following variables are used only in the netcdf file + zmax(6) = MAXVAL( tsn(:,:,:,jp_tem)*tmask ) ! temperature max + zmax(5) = zmax(6) - MAXVAL( (zmax(6)-tsn(:,:,:,jp_tem))*tmask ) ! minus temperature max + IF( ln_zad_Aimp ) THEN + zmax(9) = MAXVAL( Cu_adv(:,:,:)*tmask ) ! partitioning coeff. max + llmsk(:,:,:) = wmask(:,:,:) == 1._wp + IF( COUNT( llmsk(:,:,:) ) > 0 ) THEN ! avoid huge values sent back for land processors... + zmax(8) = MAXVAL( ABS( wi(:,:,:) )*wmask(:,:,:) ) ! implicit vertical vel. max + ENDIF + ENDIF + ENDIF + ENDIF + zmax(7) = REAL( nstop , wp ) ! stop indicator + ! + IF( ll_colruns ) THEN + zmaxlocal(:) = zmax(:) + CALL mpp_max( "stpctl", zmax ) ! max over the global domain + nstop = NINT( zmax(7) ) ! nstop indicator sheared among all local domains + ENDIF + ! !== run statistics ==! ("run.stat" files) + IF( ll_wrtruns ) THEN + WRITE(numrun,9500) kt, zmax(1), zmax(2), -zmax(3), zmax(4) + istatus = NF90_PUT_VAR( idrun, idssh, (/ zmax(1)/), (/kt/), (/1/) ) + istatus = NF90_PUT_VAR( idrun, idu, (/ zmax(2)/), (/kt/), (/1/) ) + istatus = NF90_PUT_VAR( idrun, ids1, (/-zmax(3)/), (/kt/), (/1/) ) + istatus = NF90_PUT_VAR( idrun, ids2, (/ zmax(4)/), (/kt/), (/1/) ) + istatus = NF90_PUT_VAR( idrun, idt1, (/-zmax(5)/), (/kt/), (/1/) ) + istatus = NF90_PUT_VAR( idrun, idt2, (/ zmax(6)/), (/kt/), (/1/) ) + IF( ln_zad_Aimp ) THEN + istatus = NF90_PUT_VAR( idrun, idw1, (/ zmax(8)/), (/kt/), (/1/) ) + istatus = NF90_PUT_VAR( idrun, idc1, (/ zmax(9)/), (/kt/), (/1/) ) + ENDIF + IF( kt == nitend ) istatus = NF90_CLOSE(idrun) + END IF + ! !== error handling ==! + 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) >= 0._wp .OR. & ! negative or zero sea surface salinity + & zmax(4) >= 100._wp .OR. & ! too large sea surface salinity ( > 100 ) + & zmax(4) < 0._wp .OR. & ! too large sea surface salinity (keep this line for sea-ice) + & ISNAN( zmax(1) + zmax(2) + zmax(3) ) .OR. & ! NaN encounter in the tests + & ABS( zmax(1) + zmax(2) + zmax(3) ) > HUGE(1._wp) ) THEN ! Infinity encounter in the tests + IF( ll_colruns ) THEN + ! first: close the netcdf file, so we can read it + IF( lwm .AND. kt /= nitend ) istatus = NF90_CLOSE(idrun) + CALL mpp_maxloc( 'stpctl', ABS(sshn) , ssmask(:,:) , zzz, ih(1:2) ) ; ih(3) = 0 + CALL mpp_maxloc( 'stpctl', ABS(un) , umask (:,:,:), zzz, iu ) + CALL mpp_minloc( 'stpctl', tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, is1 ) + CALL mpp_maxloc( 'stpctl', tsn(:,:,:,jp_sal), tmask (:,:,:), zzz, is2 ) + ! find which subdomain has the max. + iareamin(:) = jpnij+1 ; iareamax(:) = 0 ; iareasum(:) = 0 + DO ji = 1, 9 + 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 + ih(1:2)= MAXLOC( ABS( sshn(:,:) ) ) + (/ nimpp - 1, njmpp - 1 /) ; ih(3) = 0 + iu(:) = MAXLOC( ABS( un (:,:,:) ) ) + (/ nimpp - 1, njmpp - 1, 0 /) + is1(:) = MAXLOC( (zmax(4)-tsn(:,:,:,jp_sal))*tmask(:,:,:) ) + (/ nimpp - 1, njmpp - 1, 0 /) + is2(:) = MAXLOC( tsn(:,:,:,jp_sal)*tmask(:,:,:) ) + (/ nimpp - 1, njmpp - 1, 0 /) + 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), ih , iareasum(1), iareamin(1), iareamax(1) ) + CALL wrt_line(ctmp3, kt, ' |U| max ', zmax(2), iu , iareasum(2), iareamin(2), iareamax(2) ) + CALL wrt_line(ctmp4, kt, ' Sal min ', - zmax(3), is1, iareasum(3), iareamin(3), iareamax(3) ) + CALL wrt_line(ctmp5, kt, ' Sal max ', zmax(4), is2, 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( '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/NEMO_4.0.4_surge/src/OCE/timing.F90 b/NEMO_4.0.4_surge/src/OCE/timing.F90 new file mode 100644 index 0000000..73c7c14 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/timing.F90 @@ -0,0 +1,868 @@ +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 + +#if defined key_mpp_mpi + INCLUDE 'mpif.h' +#endif + + ! 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$ + !! 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. + s_timer%niter = s_timer%niter + 1 + s_timer%t_cpu = 0. + s_timer%t_clock = 0. + + ! CPU time collection + CALL CPU_TIME( s_timer%t_cpu ) + ! clock time collection +#if defined key_mpp_mpi + s_timer%t_clock= MPI_Wtime() +#else + CALL SYSTEM_CLOCK(COUNT_RATE=s_timer%ncount_rate, COUNT_MAX=s_timer%ncount_max) + CALL SYSTEM_CLOCK(COUNT = s_timer%ncount) +#endif +! 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 +#if defined key_mpp_mpi + zmpitime = MPI_Wtime() +#else + CALL SYSTEM_CLOCK(COUNT = ifinal_count) +#endif + ! 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 +#if defined key_mpp_mpi + 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 +#else + iperiods = ifinal_count - s_timer%ncount + IF( ifinal_count < s_timer%ncount ) & + iperiods = iperiods + s_timer%ncount_max + zclock_raw = REAL(iperiods) / s_timer%ncount_rate !- t_overclock + s_timer%t_clock = zclock_raw - s_timer%tsub_clock +#endif + ! 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 + !!---------------------------------------------------------------------- + !! *** ROUTINE timing_init *** + !! ** Purpose : open timing output file + !!---------------------------------------------------------------------- + INTEGER :: iperiods, istart_count, ifinal_count + REAL(wp) :: zdum + LOGICAL :: ll_f + + IF( ln_onefile ) THEN + IF( lwp) CALL ctl_opn( numtime, 'timing.output', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout,.TRUE., narea ) + lwriter = lwp + ELSE + CALL ctl_opn( numtime, 'timing.output', '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 +#if defined key_mpp_mpi + t_overclock = MPI_WTIME() + t_overclock = MPI_WTIME() - t_overclock +#else + CALL SYSTEM_CLOCK(COUNT_RATE=ncount_rate, COUNT_MAX=ncount_max) + CALL SYSTEM_CLOCK(COUNT = istart_count) + CALL SYSTEM_CLOCK(COUNT = ifinal_count) + iperiods = ifinal_count - istart_count + IF( ifinal_count < istart_count ) & + iperiods = iperiods + ncount_max + t_overclock = REAL(iperiods) / ncount_rate +#endif + + ! 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)) +#if defined key_mpp_mpi + ! Start elapsed and CPU time counters + t_elaps(1) = MPI_WTIME() +#else + CALL SYSTEM_CLOCK(COUNT_RATE=ncount_rate, COUNT_MAX=ncount_max) + CALL SYSTEM_CLOCK(COUNT = ncount) +#endif + ! + 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 +#if defined key_mpp_mpi + t_elaps(2) = MPI_WTIME() - t_elaps(1) - t_overclock +#else + CALL SYSTEM_CLOCK(COUNT = nfinal_count) + iperiods = nfinal_count - ncount + IF( nfinal_count < ncount ) & + iperiods = iperiods + ncount_max + t_elaps(2) = REAL(iperiods) / ncount_rate - t_overclock +#endif + + ! 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 + +#if defined key_mpp_mpi + ! 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(:)) +#else + tot_etime = t_elaps(2) + tot_ctime = t_cpu (2) +#endif + + ! 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 defined key_mpp_mpi + IF( ll_averep ) CALL waver_info + CALL wmpi_info +#endif + 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) + +#if defined key_mpp_mpi + 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 + 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. ) 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. ) 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 + zsypd = rn_rdt * 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) +#endif + + 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) ) + 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 + +#if defined key_mpp_mpi + 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) ) + 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 +#endif + + + 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/NEMO_4.0.4_surge/src/OCE/trc_oce.F90 b/NEMO_4.0.4_surge/src/OCE/trc_oce.F90 new file mode 100644 index 0000000..d3e7d1b --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/trc_oce.F90 @@ -0,0 +1,259 @@ +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 + INTEGER , PUBLIC :: nn_dttrc !: frequency of step on passive tracers + REAL(wp), PUBLIC :: r_si2 !: largest depth of extinction (blue & 0.01 mg.m-3) (RGB) + ! + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:,:) :: etot3 !: light absortion coefficient + REAL(wp), PUBLIC, SAVE, ALLOCATABLE, DIMENSION(:,:) :: oce_co2 !: ocean carbon flux + +#if defined key_top + !!---------------------------------------------------------------------- + !! 'key_top' bio-model + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_top = .TRUE. !: TOP model +#else + !!---------------------------------------------------------------------- + !! Default option No bio-model light absorption + !!---------------------------------------------------------------------- + LOGICAL, PUBLIC, PARAMETER :: lk_top = .FALSE. !: TOP model +#endif + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! 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), 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(lwp .AND. nn_print >= 1 ) 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 : 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/NEMO_4.0.4_surge/src/OCE/vectopt_loop_substitute.h90 b/NEMO_4.0.4_surge/src/OCE/vectopt_loop_substitute.h90 new file mode 100644 index 0000000..233bee1 --- /dev/null +++ b/NEMO_4.0.4_surge/src/OCE/vectopt_loop_substitute.h90 @@ -0,0 +1,18 @@ + !!---------------------------------------------------------------------- + !! *** vectopt_loop_substitute *** + !!---------------------------------------------------------------------- + !! ** purpose : substitute the inner loop start/end indices with CPP macro + !! allow unrolling of do-loop (useful with vector processors) + !!---------------------------------------------------------------------- + !!---------------------------------------------------------------------- + !! NEMO/OCE 4.0 , NEMO Consortium (2018) + !! $Id$ + !! Software governed by the CeCILL license (see ./LICENSE) + !!---------------------------------------------------------------------- +#if defined key_vectopt_loop +# define fs_2 1 +# define fs_jpim1 jpi +#else +# define fs_2 2 +# define fs_jpim1 jpim1 +#endif diff --git a/NEMO_4.0.4_surge/src/README.rst b/NEMO_4.0.4_surge/src/README.rst new file mode 100644 index 0000000..4ea8114 --- /dev/null +++ b/NEMO_4.0.4_surge/src/README.rst @@ -0,0 +1,15 @@ +******* +Sources +******* + +.. todo:: + + + +:file:`ICE`: |NEMO-ICE| + +:file:`NST`: AGRIF for embedded zooms + +:file:`OCE`: |NEMO-OCE| + +:file:`TOP`: |NEMO-MBG| diff --git a/README.md b/README.md index 61d7da7..33d7658 100644 --- a/README.md +++ b/README.md @@ -1,14 +1,14 @@ # AMM7_surge -[![DOI](https://zenodo.org/badge/293564924.svg)](https://zenodo.org/badge/latestdoi/293564924) +[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.10605585.svg)](https://doi.org/10.5281/zenodo.10605585) -A 7km resolution Atlantic Margin Model 2D surge configuration. +A 7km resolution Atlantic Margin Model 2D surge configuration, based on v4.0.4 of the [NEMO](https://www.nemo-ocean.eu) modelling framework. -The configuration is based on v3.6 of the [NEMO](https://www.nemo-ocean.eu) modelling framework. +The configuration has example demonstrations written for the [ARCHER2](https://www.archer2.ac.uk) UK National Supercomputing Service, or to be run in a Singularity container. -The configuration recipe has be written for the [ARCHER2](https://www.archer2.ac.uk) UK National Supercomputing Service. +This release includes a tutorial describing how to configure and run a tides-only and a tide+meteorolgy example. -The recipe describes how to configure and run a tides-only example. +This collaboration was facilitated by the [National Partnership for Ocean Prediction](https://oceanprediction.org/) and the [Joint Marine Modelling Programme](https://www.metoffice.gov.uk/research/approach/collaboration/joint-marine-modelling-programme). --- @@ -18,22 +18,29 @@ The recipe describes how to configure and run a tides-only example. A recipe on how to build and run AMM7_surge model. -### EXP_tideonly - -An experiment directory for a (FES2014) tide only demonstration simulation. - ### INPUTS -Store for external forcing files (e.g. tides, meteorology) and domain configuration file. Also store for boundary condition setup namelist file. *The domain configuration file can be downloaded from elsewhere. The tidal boundaries can be generated from this recipe or downloaded elsewhere*. +A store for external forcing files (e.g. tides, meteorology) and domain configuration file. Also store for boundary condition setup namelist file. *The domain configuration file can be downloaded from elsewhere. The tidal boundaries can be generated from this recipe or downloaded elsewhere*. ### ARCH Store for architecture build files. -### MY_SRC +### NEMO_4.0.4_surge + +Parent directory for source code and experiment set up files + +### NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC Store for FORTRAN modification to NEMO checkout from NEMO repository. +### NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_NOWIND_DEMO + +An experiment directory for a tide only (FES2014) demonstration simulation. + +### NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO + +An experiment directory for a tide (FES2014) + surface wind and sea level pressure forced (ERA5) demonstration simulation. --- @@ -41,4 +48,56 @@ Store for FORTRAN modification to NEMO checkout from NEMO repository. To run the AMM7 surge model follow the [AMM7_surge recipe](docs/AMM7_SURGE_build_and_run.rst). This recipe forms a template of how to obtain, compile and run the code. -As noted additional files are required to run the code. To run a full surge model meteorological forcing is required. For simplicity this demonstration simulation is configured to run without meteorological forcing (otherwise requiring sea level pressure and 10m winds). Tidal boundary conditions are also required - these can be generated following this [recipe](docs/generate_tidal_boundaries.rst) from the [docs](docs) folder, or downloaded elsewhere. Finally a domain configuration file is required - this can be generated following NEMO guidelines or downloaded elsewhere. +In the demonstration examples are given how to run on ARCHER2 and also how to run in a Singularity container (which has been independently tested on a macbook and a linux server). + +As noted additional files are required to run the code. These include: a domain file, boundary tides, sea level pressure and 10m winds. The are expected to be copied into the INPUTS folder. Example files are downloadable from ... + + +--- + + +## Configuration Input Files + +| **Input** | **Download Location** | +|-------------- | -------------- | +| **Domain_cfg.nc** | https://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/domain_cfg.nc | +| **Open ocean boundary coordinates.bdy.nc** | http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/coordinates.bdy.nc | +| **Bottom friction 2D scaling bfr_coef.nc** | http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/bfr_coef.nc | + +Example extraction into INPUTS directory: + +``` +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/domain_cfg.nc -O INPUTS/amm7_surge_domain_cfg.nc +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/coordinates.bdy.nc -O INPUTS/coordinates.bdy.nc +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/bfr_coef.nc -O INPUTS/bfr_coef.nc +``` +--- + +## Sample Forcing Files + +| **Forcing** | **Download Location** | +|-------------- | ------------------| +| **Surface boundary** | http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ | +| **Tide** | https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/ | + +Example extraction into INPUTS directory: + +``` +cd INPUTS/fluxes +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_U10_y2017.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_V10_y2017.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_MSL_y2017.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_LSM.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/weights_era5_bicubic.nc . + +cd INPUTS/bdydta +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_M2_grid_U.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_M2_grid_V.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_M2_grid_T.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_S2_grid_U.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_S2_grid_V.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_S2_grid_T.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_K2_grid_U.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_K2_grid_V.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_K2_grid_T.nc . +``` diff --git a/README_Anemone.md b/README_Anemone.md new file mode 100644 index 0000000..540d9dd --- /dev/null +++ b/README_Anemone.md @@ -0,0 +1,130 @@ +# AMM7_surge + +[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.10605585.svg)](https://doi.org/10.5281/zenodo.10605585) + +A 7km resolution Atlantic Margin Model 2D surge configuration, based on v4.0.4 of the [NEMO](https://www.nemo-ocean.eu) modelling framework. + +The configuration has example demonstrations written for the [ARCHER2](https://www.archer2.ac.uk) UK National Supercomputing Service, or to be run in a Singularity container. + +This release includes a tutorial describing how to configure and run a tides-only and a tide+meteorolgy example. + +This collaboration was facilitated by the [National Partnership for Ocean Prediction](https://oceanprediction.org/) and the [Joint Marine Modelling Programme](https://www.metoffice.gov.uk/research/approach/collaboration/joint-marine-modelling-programme). + +--- + +## Repository File Hierarchy + +### DOCS + +A recipe on how to build and run AMM7_surge model on the NOC HPC cluster Anemone. + +### INPUTS + +A store for external forcing files (e.g. tides, meteorology) and domain configuration file. Also store for boundary condition setup namelist file. *The domain configuration file can be downloaded from elsewhere. The tidal boundaries can be generated from this recipe or downloaded elsewhere*. + +### ARCH + +Store for architecture build files. + +### NEMO_4.0.4_surge + +Parent directory for source code and experiment set up files + +### NEMO_4.0.4_surge/cfgs/AMM7_SURGE/MY_SRC + +Store for FORTRAN modification to NEMO checkout from NEMO repository. + +### NEMO_4.0.4_surge/cfgs/AMM7_SURGE/EXP_ERA5_DEMO + +An experiment directory for a tide (FES2014) + surface wind and sea level pressure forced (ERA5) demonstration simulation. + +--- + +### Setting up AMM7 surge model + +To run the AMM7 surge model on Anemone follow the recipe below. + +``` +ssh anemone + +module purge +module load NEMO/prg-env + +# Navigate to a suitable directory +# cd my_work_dir + +export CONFIG=AMM7_SURGE +export WORK=$PWD +export WDIR=$WORK/$CONFIG +export INPUTS=$WDIR/INPUTS +export CDIR=$WDIR/NEMO_4.0.4_surge/cfgs # compile location is down here +export EXP=$CDIR/$CONFIG/EXP_ERA5_DEMO + +# clone repo +git clone -b feature/v4.0.4 https://github.com/JMMP-Group/AMM7_surge.git $CONFIG + +# cp arch file for compiling nemo +cd $CDIR/.. +sed "s|XXX_XIOS_XXX|$WDIR/xios|g" ../ARCH/ANEMONE/arch-anemone-ifort-impi.fcm > arch/NOC/arch-anemone-ifort-impi.fcm +cd $WDIR + +# extract xios and compile +svn co https://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5@1964 xios +cd xios +cp ../ARCH/ANEMONE/XIOS/* arch/ +./make_xios --full --prod --arch anemone-ifort-impi --netcdf_lib netcdf4_par --job 10 + +# compile nemo +cd $CDIR +echo "AMM7_SURGE OCE" >> ref_cfgs.txt +cd $CDIR/.. +./makenemo -m anemone-ifort-impi -r AMM7_SURGE -j 16 + +# tidy up a messy exp directory +cd $EXP +rm xios_server.exe +rm nemo +rm bdydta +ln -s ../../../../xios/bin/xios_server.exe +ln -s ../EXP00/nemo + +# grab inputs +cd ../ +mkdir INPUTS +mkdir INPUTS/fluxes +mkdir INPUTS/bdydta + +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/domain_cfg.nc -O INPUTS/amm7_surge_domain_cfg.nc +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/coordinates.bdy.nc -O INPUTS/coordinates.bdy.nc +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7_surge/bfr_coef.nc -O INPUTS/bfr_coef.nc + +cd INPUTS/fluxes +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_U10_y2017.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_V10_y2017.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_MSL_y2017.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/ERA5_LSM.nc . +wget http://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/SBC/weights_era5_bicubic.nc . + +cd ../../ +cd INPUTS/bdydta +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_M2_grid_U.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_M2_grid_V.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_M2_grid_T.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_S2_grid_U.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_S2_grid_V.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_S2_grid_T.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_K2_grid_U.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_K2_grid_V.nc . +wget https://gws-access.jasmin.ac.uk/public/jmmp/AMM7/inputs/TIDE/FES/AMM7_surge_bdytide_rotT_K2_grid_T.nc . + +cd $EXP +ln -s ../INPUTS/ +ln -s INPUTS/bdydta/ +ln -s INPUTS/fluxes +ln -s ../INPUTS/amm7_surge_domain_cfg.nc +ln -s ../INPUTS/bfr_coef.nc +ln -s ../INPUTS/coordinates.bdy.nc + +# submit a run +sbatch runscript_anemone.slurm +``` diff --git a/docs/AMM7_SURGE_build_and_run.rst b/docs/AMM7_SURGE_build_and_run.rst index 2773374..02d582b 100644 --- a/docs/AMM7_SURGE_build_and_run.rst +++ b/docs/AMM7_SURGE_build_and_run.rst @@ -6,16 +6,32 @@ Setting up and running the NEMO AMM7 surge model ************************************************ This recipe describes how to build NEMO and XIOS appropriate for a surge model. -For simplicity, in this example meteorological forcing is switched off. -The method for generating the tidal boundary conditions is given. The method for -generating the domain file (i.e. the grid and bathymetry) is not given. However -the tidal boundary conditions and domain configuration file can be downloaded elsewhere. +Example domain file (i.e. the grid and bathymetry), tidal and meterology forcing are shared here. Guidance for generating these files can be found elsewhere (see references). +To run NEMO you need to build NEMO and XIOS with the appropriate libraries. In my experience building the netcdf libraries is problematic. -1) Get NEMO codebase -==================== +Here we present a solution that runs on ARCHER2.ac.uk. +We also present a solution that uses containers so that the libraries can be more easily controlled. But you have to install Singularity, or equivalent. -Login to ARCHER :: +A basic "operating system for NEMO" container can be downloaded from https://github.com/NOC-MSM/CoNES/releases/download/0.0.2/nemo_baseOS.sif, or better still you can follow instructions on the CoNES repository to build you own version. You will place this in your INPUTS directory. You can then open a command line shell in the container and it is like running on a new machine with all the libraries and compilers sorted out. + +The source code in the directory `NEMO_4.0.4_surge` was made available from:: + + https://code.metoffice.gov.uk/svn/nemo/NEMO/branches/UKMO/NEMO_4.0.4_surge/ + +In this processes the source code was stripped back to make a light weight configuration. In previous and future versions the surge configuration will be shared as edits to version controlled official releases. This surge configuration falls between the gaps as NEMO transitioned from svn to git and so a pragmatic solution is given. + +Binaries files for the example forcings and domain file (best kept separate from git repositories) are available for download - links are on the README. +Download these and copy them into the `INPUTS` directory for the git cloned surge repository. + +The remaining setup instructions are machine dependent. Two examples are given: 1) ARCHER2 HPC; 2) Using a Singularity container. + +1) Building and running on ARCHER2 HPC +====================================== + +As an example the following process has been used on ARCHER2 using XIOS2 and the CRAY compiler (valid at 22nd Jan 2024) + +Login to ARCHER2 :: ssh -l $USER login.archer2.ac.uk @@ -25,188 +41,202 @@ Define some paths :: export WORK=/work/n01/n01 export WDIR=/work/n01/n01/$USER/$CONFIG export INPUTS=$WDIR/INPUTS - export START_FILES=$WDIR/START_FILES - export CDIR=$WDIR/dev_r8814_surge_modelling_Nemo4/CONFIG - export TDIR=$WDIR/dev_r8814_surge_modelling_Nemo4/TOOLS - export EXP=$CDIR/$CONFIG/EXP_tideonly - + export CDIR=$WDIR/NEMO_4.0.4_surge/cfgs # compile location is down here + export EXP=$CDIR/$CONFIG/EXP_ERA5_DEMO Clone the repository :: cd $WORK/$USER - git clone https://github.com/JMMP-Group/AMM7_surge.git $CONFIG + git clone -b feature/v4.0.4 https://github.com/JMMP-Group/AMM7_surge.git $CONFIG -Get the code:: - cd $WDIR - svn co http://forge.ipsl.jussieu.fr/nemo/svn/branches/UKMO/dev_r8814_surge_modelling_Nemo4/NEMOGCM dev_r8814_surge_modelling_Nemo4 +Get compiler option files using a shared XIOS2 install:: -Make a link between where the inputs files are and where the model expects them :: + cd $CDIR/.. + cp /work/n01/shared/nemo/ARCH/*4.2.fcm arch/NOC/. - mkdir $EXP - ln -s $INPUTS $EXP/bdydta +Load some modules:: -Put files from git repo into ``MY_SRC``:: + module swap craype-network-ofi craype-network-ucx + module swap cray-mpich cray-mpich-ucx + module load cray-hdf5-parallel/1.12.2.1 + module load cray-netcdf-hdf5parallel/4.9.0.1 - rsync -vt $WDIR/MY_SRC/* $CDIR/$CONFIG/MY_SRC -Add files to the experiment directory. This demonstration is tide-only:: +Compile NEMO:: - rsync -vt $WDIR/EXP_tideonly/* $CDIR/$CONFIG/EXP_tideonly + cd $CDIR + echo "AMM7_SURGE OCE" >> ref_cfgs.txt + cd $CDIR/.. + ./makenemo -m X86_ARCHER2-Cray_4.2 -r AMM7_SURGE -j 16 -NB Have added a couple of extra lines into the field_def files. This is a glitch in the surge code, -because it doesn't expect you to not care about the winds:: +Link executables to experiment directory (first remove any old existing placeholder links, as appropriate):: - vi $EXP/field_def_nemo-opa.xml - line 338 - <field id="wspd" long_name="wind speed module" standard_name="wind_speed" unit="m/s" /> unit="m/s" /> - <field id="uwnd" long_name="u component of wind" unit="m/s" /> - <field id="vwnd" long_name="v component of wind" unit="m/s" /> + cd $EXP + ln -s /work/n01/shared/nemo/XIOS2_Cray/bin/xios_server.exe $EXP/xios_server.exe + ln -s $CDIR/$CONFIG/BLD/bin/nemo.exe $EXP/nemo +(N.B. sometimes the executable is expected to be called `opa` or `nemo.exe`) -Load some modules:: - module restore - source /opt/cray/pe/cpe/22.12/restore_lmod_system_defaults.sh - - module swap PrgEnv-cray/8.3.3 PrgEnv-gnu/8.3.3 - module swap craype-network-ofi craype-network-ucx - module swap cray-mpich cray-mpich-ucx - module load cray-hdf5-parallel/1.12.2.1 - module load cray-netcdf-hdf5parallel/4.9.0.1 - module load libfabric +Populate the INPUTS directory according to the README. Then make a link between binaries and where they are expected to be found (first remove any old existing placeholder links, as appropriate):: -2) Build XIOS -============= + cd $EXP + ln -s /work/n01/n01/shared/CO_AMM7/TIDE/FES $EXP/bdydta + ln -s /work/n01/n01/shared/AMM7-INPUTS-OLD/SBC/ATM $EXP/fluxes + ln -s $INPUTS/coordinates.bdy.nc $EXP/coordinates.bdy.nc + ln -s $INPUTS/bfr_coef.nc $EXP/bfr_coef.nc + ln -s $INPUTS/amm7_surge_domain_cfg.nc $EXP/amm7_surge_domain_cfg.nc -Download XIOS2.5 and prep:: +Finally we are ready to submit a run script job from the experiment directory. +Edit the runscript. - cd $WORK/$USER - svn co -r2528 http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS/branchs/xios-2.5/ xios-2.5_r2528 - cd xios-2.5_r2528 +Submit:: -Make a mod (line 480). Though you might need to run the ``make_xios`` command -once first to unpack the tar files:: + cd $EXP + sbatch runscript.slurm + +Sea surface height is output every 15 mins:: + + AMMSRG_met_15mi_20170101_20170206_grid_V.nc + AMMSRG_met_15mi_20170101_20170206_grid_U.nc + AMMSRG_met_15mi_20170101_20170206_grid_T.nc + + +2) Building and running in a Singularity Container +================================================== + +There are many reasons why ARCHER2 is not suitable. Here is the workflow to get the code running in a Singularity container, on the assumption that you have already got Singularity installed. + +Set up some paths:: - vi tools/FCM/lib/Fcm/Config.pm - FC_MODSEARCH => '-J', # FC flag, specify "module" path + export CONFIG=AMM7_SURGE + export WORK=/work/$USER/TEST + export WDIR=$WORK/$CONFIG + export GIT_DIR=$WORK/$CONFIG + export INPUTS=$WDIR/INPUTS + export CDIR=$WDIR/NEMO_4.0.4_surge/cfgs # compile location is down here + export XIOS_DIR=$WORK/XIOS2 + export EXP=$CDIR/$CONFIG/EXP_NOWIND_DEMO +This workflow includes the building of XIOS. The idea is to use a container with a controlled operating system and prebuilt libraries so that you can be confident that the NEMO and XIOS programs will compile:: -Copy architecture files from ?git? repo:: + cd $WORK + wget https://github.com/NOC-MSM/CoNES/releases/download/0.0.2/nemo_baseOS.sif # 297Mb + chmod u+x nemo_baseOS.sif + singularity shell ./nemo_baseOS.sif - cp /work/n01/n01/annkat/SE-NEMO_UPD/SE-NEMO/arch/xios/arch-archer2-gnu-mpich.* arch/. -Implement make command:: - ./make_xios --prod --arch archer2-gnu-mpich --netcdf_lib netcdf4_par --job 16 --full +Set up some library paths that have been preprepared:: -Link the xios-2.5_r2528 to a generic XIOS directory name:: + PATH=$PATH:/opt/mpi/install/bin:/opt/hdf5/install/bin + LD_LIBRARY_PATH=/opt/hdf5/install/lib:$LD_LIBRARY_PATH - ln -s $WORK/$USER/xios-2.5_r2528 $WORK/$USER/XIOS -Link xios executable to the EXP directory:: - ln -s $WORK/$USER/xios-2.5_r2528/bin/xios_server.exe $EXP/xios_server.exe +Clone the configuration repository (and select the appropriate branch):: + git clone -b feature/v4.0.4 https://github.com/JMMP-Group/AMM7_surge.git $CONFIG -3) Build NEMO -============== -Already got NEMO branch :: - #cd $WDIR - #svn co http://forge.ipsl.jussieu.fr/nemo/svn/branches/UKMO/dev_r8814_surge_modelling_Nemo4/NEMOGCM dev_r8814_surge_modelling_Nemo4 +Clone the XIOS repository, and copy in the arch files:: + cd $WORK + svn co http://forge.ipsl.jussieu.fr/ioserver/svn/XIOS2/trunk XIOS2 + cd $XIOS_DIR + cp $GIT_DIR/ARCH/SINGULARITY/xios/* arch/. -Copy files required to build ``nemo.exe``. Or get it from git repo. Or get it here. -Set the compile flags (will use the FES tide) :: +Compile:: - vi $CDIR/$CONFIG/cpp_AMM7_SURGE.fcm - bld::tool::fppkeys key_nosignedzero key_diainstant key_mpp_mpi key_iomput \ - key_diaharm_fast key_FES14_tides + ./make_xios --full --debug --arch singularity --netcdf_lib netcdf4_par -j 8 -Put the HPC compiler file (from the git repo) in the correct place (this -currently uses xios2.5 from acc) :: +NB ``./make_xios --full --prod --arch singularity --netcdf_lib netcdf4_par -j 8`` does not work... - rsync -vt /work/n01/n01/annkat/SE-NEMO_UPD/SE-NEMO/arch/nemo/arch-archer2-gnu-mpich.fcm $CDIR/../ARCH/. +This builds the ``$XIOS_DIR/bin/xios_server.exe`` executable and libraries, which need to be linked into the NEMO builds. -# Dirty fix to hard wire path otherwise user will have to set XIOS_DIR in every new shell session:: +Edit the NEMO arch files to point to new XIOS builds:: - sed -i "s?XXX_XIOS_DIR_XXX?$WORK/$USER/XIOS?" $CDIR/../ARCH/arch-archer2-gnu-mpich.fcm + sed -i "s?XXX_XIOS_DIR_XXX?$XIOS_DIR?g" $GIT_DIR/ARCH/SINGULARITY/nemo/arch-singularity.fcm -Make a mod (line 480). Though you might need to run the ``make_xios`` command -once first to unpack the tar files:: - vi $WDIR/dev_r8814_surge_modelling_Nemo4/EXTERNAL/fcm/lib/Fcm/Config.pm - FC_MODSEARCH => '-J', # FC flag, specify "module" path +Copy arch files for NEMO build into place:: + + cp $GIT_DIR/ARCH/SINGULARITY/nemo/*.fcm $CDIR/../arch/. + -Make NEMO :: + +Compile NEMO, as before:: cd $CDIR - ./makenemo -n $CONFIG -m archer2-gnu-mpich -j 16 + echo "AMM7_SURGE OCE" >> ref_cfgs.txt + cd $CDIR/.. + ./makenemo -m singularity -r AMM7_SURGE -j 16 + -Copy executable to experiment directory :: +Link executables to experiment directory (first remove any old existing placeholder links, as appropriate):: + ln -s $XIOS_DIR/bin/xios_server.exe $EXP/xios_server.exe ln -s $CDIR/$CONFIG/BLD/bin/nemo.exe $EXP/nemo (N.B. sometimes the executable is expected to be called `opa` or `nemo.exe`) +Make a link between binaries and where they are expected to be found (first remove any old existing placeholder links, as appropriate):: -4) Generate a domain configuration file -======================================== + ln -s $INPUTS/bdydta $EXP/bdydta + ln -s $INPUTS/fluxes $EXP/fluxes # Not needed for no-wind example + ln -s $INPUTS/coordinates.bdy.nc $EXP/coordinates.bdy.nc + ln -s $INPUTS/bfr_coef.nc $EXP/bfr_coef.nc + ln -s $INPUTS/amm7_surge_domain_cfg.nc $EXP/amm7_surge_domain_cfg.nc -Copy a domain file that holds all the coordinates and domain discretisation. -This files is called ``domain_cfg.nc``. The generation of this file is not -described here. Obtain the file E.g. :: - cd /projects/jcomp/fred/SURGE/AMM7_INPUTS - scp amm7_surge_domain_cfg.nc jelt@login.archer.ac.uk:$INPUTS/domain_cfg.nc - ln -s $INPUTS/domain_cfg.nc $EXP/. +Run the configuration:: + mpirun -n 1 ./nemo : -n 1 ./xios_server.exe -5) Generate tidal boundary conditions -====================================== -The tidal boundary conditions were generated from the FES2014 tidal model with a tool called PyNEMO. -At this time the version of PyNEMO did not support outputting only 2D tidal forcing, -so some of the error checking for 3D boundary conditions is not needed but has -to be satisfied. This is how it was done. A new version of PyNEMO now exists. -The boundary data are stored in ``$INPUTS`` -See **generate tidal boundaries** page. -6) Summary of external requirements -=================================== -To successfully run NEMO will expect a ``coordinates.bdy.nc`` file in `$INPUTS` -(generated by PyNEMO) it will also expect boundary files of the type:: - AMM7_surge_bdytide_rotT_*.nc - amm7_bdytide_*.nc -E.g. ``AMM7_surge_bdytide_rotT_M2_grid_V.nc`` and ``amm7_bdytide_M2_grid_T.nc`` -There must also be a ``domain_cfg.nc`` domain file in ``$EXP``. +************************************************ +Generate tidal boundary conditions +************************************************ +The tidal boundary conditions were generated from the FES2014 tidal model with a tool called ``PyBDY`` <https://github.com/NOC-MSM/pyBDY> +The boundary data are stored in ``$INPUTS``. Data are provided for this configuration. Notes for generating tidal files for other configurations can be found e.g. https://github.com/JMMP-Group/SEVERN-SWOT/wiki/04.-Make-tidal-boundary-conditions -7) Run NEMO -=========== -Finally we are ready to submit a run script job from the experiment directory. +************************************************ +Generate surface forcing +************************************************ -Edit the runscript (to be downloaded from repo but not settled on processor -split yet) +The surge model requires 10m wind velocity and atmospheric pressure. As a demonstration some example data is provided that has been processed from the ERA5 dataset. Data were processed using the tool ``pySBC`` <https://github.com/NOC-MSM/pySBC> -Submit:: +************************************************ +2D bottom friction coefficients +************************************************ - cd $EXP - mkdir Restart_files - sbatch runscript.slurm +This surge configuration uses 2D spatially varying bottom friction coefficients. These were generated following Warder and Piggot (2022) +and converted into depth vary drag coefficents. The map is implemented as a scaling on the existing drag coefficient. + +************************************************ +Useful references +************************************************ + +* SEAsia wiki notes (https://zenodo.org/record/6483231) +* Julian Mak's NEMO notes: https://nemo-related.readthedocs.io/en/latest/ +* Collated guidance in Polton et al (2023). Reproducible and relocatable regional ocean modelling: fundamentals and practices. DOI: https://doi.org/10.5194/gmd-16-1481-2023 +* Polton, J. A., Wise, A., O'Neill, C. K., & O'Dea, E. (2020). AMM7-surge: A 7km resolution Atlantic Margin Model surge configuration using NEMOv3.6 (v0.0.9). Zenodo. https://doi.org/10.5281/zenodo.4022310 +* Old notes on generating boundary conditions from previous AMM7_surge release: https://github.com/JMMP-Group/AMM7_surge/blob/v0.0.9/docs/generate_tidal_boundaries.rst +* Warder and Piggott (2022). Optimal experiment design for a bottom friction parameter estimation problem. GEM - International Journal on Geomathematics DOI: https://doi.org/10.1007/s13137-022-00196-4 -Sea surface height is output every 15 mins. diff --git a/docs/generate_tidal_boundaries.rst b/docs/generate_tidal_boundaries.rst deleted file mode 100644 index 4ec37ac..0000000 --- a/docs/generate_tidal_boundaries.rst +++ /dev/null @@ -1,237 +0,0 @@ - -.. _generate-tidal-boundaries-label: - -Generate tidal boundary conditions -================================== - -The boundary conditions were generated with a tool called PyNEMO. At this time -the version of PyNEMO did not support outputting only 2D tidal forcing, -so some of the error checking for 3D boundary conditions is not needed but has -to be satisfied. This is how it was done. A new version of PyNEMO now exists. - - - -Install PyNEMO -============== - -Method for installing on a centos box. NB At this time PyNEMO was briefly called ``nrct``:: - - export CONFIG=AMM7_SURGE - export WORK=/work - export WDIR=$WORK/$USER/NEMO/$CONFIG - export INPUTS=$WDIR/INPUTS - export START_FILES=$WDIR/START_FILES - - cd $WORK/$USER - mkdir $WDIR - module load anaconda/2.1.0 # Want python2 - conda create --name nrct_env scipy=0.16.0 numpy=1.9.2 matplotlib=1.4.3 basemap=1.0.7 netcdf4=1.1.9 libgfortran=1.0.0 - source activate nrct_env - conda install -c https://conda.anaconda.org/conda-forge seawater=3.3.4 # Note had to add https path - conda install -c https://conda.anaconda.org/srikanthnagella thredds_crawler - conda install -c https://conda.anaconda.org/srikanthnagella pyjnius - -Find java object by doing a ``which java`` and then following the trail -``find /usr/lib/jvm/jre-1.7.0-openjdk.x86_64/ -name libjvm.so -print`` -:: - - cd $WORK/$USER - export LD_LIBRARY_PATH=/usr/lib/jvm/jre-1.7.0-openjdk.x86_64/lib/amd64/server:$LD_LIBRARY_PATH - unset SSH_ASKPASS # Didn't need this on ARCHER... - git clone https://jpolton@bitbucket.org/jdha/nrct.git nrct # Give jpolton@bitbucket passwd - cd $WORK/$USER/nrct/Python - -For generation of FES tides need to checkout the appropriate branch :: - - git fetch - git checkout Generalise-tide-input - -You have to manually set the TPXO or FES data source in ``Python/pynemo/tide/nemo_bdy_tide3.py`` -Check this. Then build PyNEMO :: - - python setup.py build - export PYTHONPATH=/login/$USER/.conda/envs/nrct_env/lib/python2.7/site-packages/:$PYTHONPATH - python setup.py install --prefix ~/.conda/envs/nrct_env - cd $INPUTS - -If everything else is ready (it isn't) you could then just do: ``pynemo -s namelist.bdy`` - - -Create inputs files for PyNEMO -============================== - -PyNEMO is controlled by a ``namelist.bdy`` file and which -has two input files: ``inputs_src.ncml`` which points to the data source and -``inputs_dst.ncml`` which remaps some variable names in the destination files. - -Copy across some parent mesh files and a mask file (even though they are not -used. This is because this old version of PyNEMO didn't anticipate tide-only usage):: - - cp ../../SEAsia/INPUTS/mesh_?gr_src.nc $INPUTS/. - cp ../../SEAsia/INPUTS/mask_src.nc $INPUTS/. - cp ../../SEAsia/INPUTS/inputs_dst.ncml $INPUTS/. - cp ../../SEAsia/INPUTS/cut_inputs_src.ncml $INPUTS/. - - -If I don't make a boundary mask then it doesn't work... This can also be done with -the PyNEMO GUI. The mask variable takes values (-1 mask, 1 wet, 0 land). Get a -template from ``domain_cfg.nc`` and then modify as desired around the boundary :: - - module load nco/gcc/4.4.2.ncwa - rm -f bdy_mask.nc tmp[12].nc - ncks -v top_level domain_cfg.nc tmp1.nc - ncrename -h -v top_level,mask tmp1.nc tmp2.nc - ncwa -a t tmp2.nc bdy_mask.nc - rm -f tmp[12].nc - -Then in ipython:: - - import netCDF4, numpy - dset = netCDF4.Dataset('bdy_mask.nc','a') - dset.variables['mask'][0,:] = -1 # Southern boundary - dset.variables['mask'][-1,:] = -1 # Northern boundary - dset.variables['mask'][:,-1] = -1 # Eastern boundary - dset.variables['mask'][:,0] = -1 # Western boundary - dset.close() - - - -Make a bathymetry file from envelope bathymetry variable ``hbatt`` (I think -this is OK to do..):: - - module load nco/gcc/4.4.2.ncwa - rm -f hbatt.nc tmp1.nc tmp2.nc - ncks -v hbatt, nav_lat, nav_lon domain_cfg.nc tmp1.nc - ncrename -h -v hbatt,Bathymetry tmp1.nc tmp2.nc - ncwa -a t tmp2.nc hbatt.nc - - -FES2014 tidal data is used as the tidal data source. This is clumsily set in -``nemo_bdy_tide3.py`` before pynemo is built, though the attached -``namelist.bdy`` has redundant references to TPXO. The FES2014 files will need -to be obtained from https://datastore.cls.fr/catalogues/fes2014-tide-model/ - - -Run PyNEMO -========== - -Generate the boundary conditions with PyNEMO -:: - - module load anaconda/2.1.0 # Want python2 - source activate nrct_env - cd $INPUTS - export LD_LIBRARY_PATH=/usr/lib/jvm/jre-1.7.0-openjdk.x86_64/lib/amd64/server:$LD_LIBRARY_PATH - export PYTHONPATH=/login/$USER/.conda/envs/nrct_env/lib/python2.7/site-packages/:$PYTHONPATH - - pynemo -s namelist.bdy - - -This creates:: - - coordinates.bdy.nc - AMM7_surge_bdytide_rotT_NU2_grid_T.nc - AMM7_surge_bdytide_rotT_O1_grid_T.nc - AMM7_surge_bdytide_rotT_P1_grid_T.nc - AMM7_surge_bdytide_rotT_Q1_grid_T.nc - AMM7_surge_bdytide_rotT_MTM_grid_T.nc - AMM7_surge_bdytide_rotT_MU2_grid_T.nc - AMM7_surge_bdytide_rotT_N2_grid_T.nc - AMM7_surge_bdytide_rotT_N4_grid_T.nc - AMM7_surge_bdytide_rotT_R2_grid_T.nc - AMM7_surge_bdytide_rotT_S1_grid_T.nc - AMM7_surge_bdytide_rotT_2N2_grid_T.nc - AMM7_surge_bdytide_rotT_J1_grid_T.nc - AMM7_surge_bdytide_rotT_EPS2_grid_T.nc - AMM7_surge_bdytide_rotT_K2_grid_T.nc - AMM7_surge_bdytide_rotT_K1_grid_T.nc - AMM7_surge_bdytide_rotT_LA2_grid_T.nc - AMM7_surge_bdytide_rotT_L2_grid_T.nc - AMM7_surge_bdytide_rotT_M3_grid_T.nc - AMM7_surge_bdytide_rotT_M2_grid_T.nc - AMM7_surge_bdytide_rotT_M6_grid_T.nc - AMM7_surge_bdytide_rotT_M4_grid_T.nc - AMM7_surge_bdytide_rotT_MF_grid_T.nc - AMM7_surge_bdytide_rotT_M8_grid_T.nc - AMM7_surge_bdytide_rotT_MM_grid_T.nc - AMM7_surge_bdytide_rotT_MKS2_grid_T.nc - AMM7_surge_bdytide_rotT_MS4_grid_T.nc - AMM7_surge_bdytide_rotT_MN4_grid_T.nc - AMM7_surge_bdytide_rotT_MSQM_grid_T.nc - AMM7_surge_bdytide_rotT_MSF_grid_T.nc - AMM7_surge_bdytide_rotT_S4_grid_T.nc - AMM7_surge_bdytide_rotT_S2_grid_T.nc - AMM7_surge_bdytide_rotT_T2_grid_T.nc - AMM7_surge_bdytide_rotT_SSA_grid_T.nc - AMM7_surge_bdytide_rotT_SA_grid_T.nc - AMM7_surge_bdytide_rotT_NU2_grid_U.nc - AMM7_surge_bdytide_rotT_O1_grid_U.nc - AMM7_surge_bdytide_rotT_P1_grid_U.nc - AMM7_surge_bdytide_rotT_Q1_grid_U.nc - AMM7_surge_bdytide_rotT_MTM_grid_U.nc - AMM7_surge_bdytide_rotT_MU2_grid_U.nc - AMM7_surge_bdytide_rotT_N2_grid_U.nc - AMM7_surge_bdytide_rotT_N4_grid_U.nc - AMM7_surge_bdytide_rotT_R2_grid_U.nc - AMM7_surge_bdytide_rotT_S1_grid_U.nc - AMM7_surge_bdytide_rotT_2N2_grid_U.nc - AMM7_surge_bdytide_rotT_J1_grid_U.nc - AMM7_surge_bdytide_rotT_EPS2_grid_U.nc - AMM7_surge_bdytide_rotT_K2_grid_U.nc - AMM7_surge_bdytide_rotT_K1_grid_U.nc - AMM7_surge_bdytide_rotT_LA2_grid_U.nc - AMM7_surge_bdytide_rotT_L2_grid_U.nc - AMM7_surge_bdytide_rotT_M3_grid_U.nc - AMM7_surge_bdytide_rotT_M2_grid_U.nc - AMM7_surge_bdytide_rotT_M6_grid_U.nc - AMM7_surge_bdytide_rotT_M4_grid_U.nc - AMM7_surge_bdytide_rotT_MF_grid_U.nc - AMM7_surge_bdytide_rotT_M8_grid_U.nc - AMM7_surge_bdytide_rotT_MM_grid_U.nc - AMM7_surge_bdytide_rotT_MKS2_grid_U.nc - AMM7_surge_bdytide_rotT_MS4_grid_U.nc - AMM7_surge_bdytide_rotT_MN4_grid_U.nc - AMM7_surge_bdytide_rotT_MSQM_grid_U.nc - AMM7_surge_bdytide_rotT_MSF_grid_U.nc - AMM7_surge_bdytide_rotT_S4_grid_U.nc - AMM7_surge_bdytide_rotT_S2_grid_U.nc - AMM7_surge_bdytide_rotT_T2_grid_U.nc - AMM7_surge_bdytide_rotT_SSA_grid_U.nc - AMM7_surge_bdytide_rotT_SA_grid_U.nc - AMM7_surge_bdytide_rotT_NU2_grid_V.nc - AMM7_surge_bdytide_rotT_O1_grid_V.nc - AMM7_surge_bdytide_rotT_P1_grid_V.nc - AMM7_surge_bdytide_rotT_Q1_grid_V.nc - AMM7_surge_bdytide_rotT_MTM_grid_V.nc - AMM7_surge_bdytide_rotT_MU2_grid_V.nc - AMM7_surge_bdytide_rotT_N2_grid_V.nc - AMM7_surge_bdytide_rotT_N4_grid_V.nc - AMM7_surge_bdytide_rotT_R2_grid_V.nc - AMM7_surge_bdytide_rotT_S1_grid_V.nc - AMM7_surge_bdytide_rotT_2N2_grid_V.nc - AMM7_surge_bdytide_rotT_J1_grid_V.nc - AMM7_surge_bdytide_rotT_EPS2_grid_V.nc - AMM7_surge_bdytide_rotT_K2_grid_V.nc - AMM7_surge_bdytide_rotT_K1_grid_V.nc - AMM7_surge_bdytide_rotT_LA2_grid_V.nc - AMM7_surge_bdytide_rotT_L2_grid_V.nc - AMM7_surge_bdytide_rotT_M3_grid_V.nc - AMM7_surge_bdytide_rotT_M2_grid_V.nc - AMM7_surge_bdytide_rotT_M6_grid_V.nc - AMM7_surge_bdytide_rotT_M4_grid_V.nc - AMM7_surge_bdytide_rotT_MF_grid_V.nc - AMM7_surge_bdytide_rotT_M8_grid_V.nc - AMM7_surge_bdytide_rotT_MM_grid_V.nc - AMM7_surge_bdytide_rotT_MKS2_grid_V.nc - AMM7_surge_bdytide_rotT_MS4_grid_V.nc - AMM7_surge_bdytide_rotT_MN4_grid_V.nc - AMM7_surge_bdytide_rotT_MSQM_grid_V.nc - AMM7_surge_bdytide_rotT_MSF_grid_V.nc - AMM7_surge_bdytide_rotT_S4_grid_V.nc - AMM7_surge_bdytide_rotT_S2_grid_V.nc - AMM7_surge_bdytide_rotT_T2_grid_V.nc - AMM7_surge_bdytide_rotT_SSA_grid_V.nc - AMM7_surge_bdytide_rotT_SA_grid_V.nc - - -Copy these files into ``$INPUTS`` on ARCHER.